source: trunk/source/level-1/l1-streams.lisp @ 9831

Last change on this file since 9831 was 9831, checked in by gb, 12 years ago

Make CLOSE of shared ioblock-based streams thread-safe:

  • CLOSE (actually, %IOBLOCK-CLOSE) waits for all buffer locks and sets ioblock.device to NIL, does nothing if already NIL.
  • Any other function that waits for ioblock locks checks ioblock.device and signals STREAM-IS-CLOSED error if it's NIL
  • string-streams set ioblock.device to -1 (the default value) when open, follow the same protocol for close. (String-streams are generally implicitly thread-private, but it seems safest to use the same conventions.)
  • Add code to close ioblock-based streams before saving an image, tweak it to observe ioblock.device conventions.
  • Remove a few unused ioblock-lock macros, enforce the check for closed-while-waiting in other macros
  • Since CLOSE now does ownership checks, make stream finalization use CLOSE-FOR-TERMINATION, which (since it's only called when the stream isn't otherwise referenced) can clobber ioblock.owner before doing the CLOSE.

This code (modulo any remaining bugs) should go into 1.2 and other
working branches.

I don't -think- that it's hard to bootstrap, but it's important
to do a full rebuild after svn update.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 225.8 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   Portions copyright (C) 2001 Clozure Associates
5;;;   This file is part of OpenMCL. 
6;;;
7;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with OpenMCL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18(in-package "CCL")
19
20(eval-when (:compile-toplevel :execute)
21  #+linuxppc-target
22  (require "PPC-LINUX-SYSCALLS")
23  #+linuxx8664-target
24  (require "X8664-LINUX-SYSCALLS")
25  #+darwinppc-target
26  (require "DARWINPPC-SYSCALLS")
27  #+darwinx8664-target
28  (require "DARWINX8664-SYSCALLS")
29  #+freebsdx8664-target
30  (require "X8664-FREEBSD-SYSCALLS"))
31
32;;;
33
34(defclass stream ()
35  ())
36
37
38(defclass input-stream (stream)
39  ())
40
41
42(defclass output-stream (stream) ())
43
44(defmethod stream-direction ((s stream))
45  )
46
47(defmethod stream-domain ((s stream))
48  t)
49
50
51(defmethod stream-direction ((s input-stream))
52  (if (typep s 'output-stream)
53    :io
54    :input))
55
56(defmethod stream-direction ((s output-stream))
57  (if (typep s 'input-stream)
58    :io
59    :output))
60
61(defun check-io-timeout (timeout)
62  (when timeout
63    (require-type timeout '(real 0 1000000))))
64
65(defmethod stream-input-timeout ((s input-stream))
66  nil)
67
68(defmethod (setf input-stream-timeout) (new (s input-stream))
69  (check-io-timeout new))
70
71(defmethod stream-output-timeout ((s output-stream))
72  nil)
73
74(defmethod (setf stream-output-timeout) (new (s output-stream))
75  (check-io-timeout new))
76
77;;; Try to return a string containing characters that're near the
78;;; stream's current position, if that makes sense.  Return NIL
79;;; if it doesn't make sense.
80;;; Some things (SOCKET-ERRORs) are signaled as STREAM-ERRORs
81;;; whose STREAM args aren't streams.  That's wrong, but
82;;; defining this method on T keeps things from blowing up worse.
83(defmethod stream-surrounding-characters ((s t))
84  (declare (ignore s))
85  nil)
86
87
88;;; The "direction" argument only helps us dispatch on two-way streams:
89;;; it's legal to ask for the :output device of a stream that's only open
90;;; for input, and one might get a non-null answer in that case.
91(defmethod stream-device ((s stream) direction)
92  (declare (ignore direction)))
93
94;;; Some generic stream functions:
95(defmethod stream-length ((x t) &optional new)
96  (declare (ignore new))
97  (report-bad-arg x 'stream))
98
99(defmethod stream-position ((x t) &optional new)
100  (declare (ignore new))
101  (report-bad-arg x 'stream))
102
103(defmethod stream-element-type ((x t))
104  (report-bad-arg x 'stream))
105
106(defmethod stream-position ((s stream) &optional newpos)
107  (declare (ignore newpos)))
108
109;;; For input streams:
110
111;; From Shannon Spires, slightly modified.
112(defun generic-read-line (s)
113  (let* ((str (make-array 20 :element-type 'base-char
114                          :adjustable t :fill-pointer 0))
115         (eof nil))
116    (do* ((ch (read-char s nil :eof) (read-char s nil :eof)))
117         ((or (eq ch #\newline) (setq eof (eq ch :eof)))
118          (values (ensure-simple-string str) eof))
119      (vector-push-extend ch str))))
120
121(defun generic-character-read-list (stream list count)
122  (declare (fixnum count))
123  (do* ((tail list (cdr tail))
124        (i 0 (1+ i)))
125       ((= i count) count)
126    (declare (fixnum i))
127    (let* ((ch (read-char stream nil :eof)))
128      (if (eq ch :eof)
129        (return i)
130        (rplaca tail ch)))))
131
132(defun generic-binary-read-list (stream list count)
133  (declare (fixnum count))
134  (do* ((tail list (cdr tail))
135        (i 0 (1+ i)))
136       ((= i count) count)
137    (declare (fixnum i))
138    (let* ((ch (stream-read-byte stream)))
139      (if (eq ch :eof)
140        (return i)
141        (rplaca tail ch)))))
142
143(defun generic-character-read-vector (stream vector start end)
144  (declare (fixnum start end))
145  (do* ((i start (1+ i)))
146       ((= i end) end)
147    (declare (fixnum i))
148    (let* ((ch (stream-read-char stream)))
149      (if (eq ch :eof)
150        (return i)
151        (setf (uvref vector i) ch)))))
152
153(defun generic-binary-read-vector (stream vector start end)
154  (declare (fixnum start end))
155  (do* ((i start (1+ i)))
156       ((= i end) end)
157    (declare (fixnum i))
158    (let* ((byte (stream-read-byte stream)))
159      (if (eq byte :eof)
160        (return i)
161        (setf (uvref vector i) byte)))))
162
163
164;;; For output streams:
165
166(defun generic-advance-to-column (s col)
167  (let* ((current (column s)))
168    (unless (null current)
169      (when (< current col)
170        (do* ((i current (1+ i)))
171             ((= i col))
172          (write-char #\Space s)))
173      t)))
174
175
176
177(defun generic-stream-write-string (stream string start end)
178  (setq end (check-sequence-bounds string start end))
179  (locally (declare (fixnum start end))
180    (multiple-value-bind (vect offset) (array-data-and-offset string)
181      (declare (fixnum offset))
182      (unless (zerop offset)
183        (incf start offset)
184        (incf end offset))
185      (do* ((i start (1+ i)))
186           ((= i end) string)
187        (declare (fixnum i))
188        (write-char (schar vect i) stream)))))
189
190
191
192
193
194
195
196
197
198
199
200
201(defloadvar *heap-ivectors* ())
202(defvar *heap-ivector-lock* (make-lock))
203
204
205
206(defun %make-heap-ivector (subtype size-in-bytes size-in-elts)
207  (with-macptrs ((ptr (malloc (+ size-in-bytes
208                                 #+32-bit-target (+ 4 2 7) ; 4 for header, 2 for delta, 7 for round up
209                                 #+64-bit-target (+ 8 2 15) ; 8 for header, 2 for delta, 15 for round up
210                                 ))))
211    (let ((vect (fudge-heap-pointer ptr subtype size-in-elts))
212          (p (%null-ptr)))
213      (%vect-data-to-macptr vect p)
214      (with-lock-grabbed (*heap-ivector-lock*)
215        (push vect *heap-ivectors*))
216      (values vect p))))
217
218(defun %heap-ivector-p (v)
219  (with-lock-grabbed (*heap-ivector-lock*)
220    (not (null (member v *heap-ivectors* :test #'eq)))))
221
222
223(defun dispose-heap-ivector (v)
224  (if (%heap-ivector-p v)
225    (with-macptrs (p)
226      (with-lock-grabbed (*heap-ivector-lock*)
227        (setq *heap-ivectors* (delq v *heap-ivectors*)))
228      (%%make-disposable p v)
229      (free p))))
230
231(defun %dispose-heap-ivector (v)
232  (dispose-heap-ivector v))
233
234(defun make-heap-ivector (element-count element-type)
235  (let* ((subtag (ccl::element-type-subtype element-type)))
236    (unless
237        #+ppc32-target
238        (= (logand subtag ppc32::fulltagmask)
239               ppc32::fulltag-immheader)
240        #+ppc64-target
241        (= (logand subtag ppc64::lowtagmask)
242           ppc64::lowtag-immheader)
243        #+x8664-target
244        (logbitp (the (mod 16) (logand subtag x8664::fulltagmask))
245                 (logior (ash 1 x8664::fulltag-immheader-0)
246                         (ash 1 x8664::fulltag-immheader-1)
247                         (ash 1 x8664::fulltag-immheader-2)))
248      (error "~s is not an ivector subtype." element-type))
249    (let* ((size-in-octets (ccl::subtag-bytes subtag element-count)))
250      (multiple-value-bind (pointer vector)
251          (ccl::%make-heap-ivector subtag size-in-octets element-count)
252        (values pointer vector size-in-octets)))))
253
254
255
256
257
258
259
260
261
262(defvar *elements-per-buffer* 2048)  ; default buffer size for file io
263
264(defmethod streamp ((x t))
265  nil)
266
267(defmethod streamp ((x stream))
268  t)
269
270(defmethod stream-io-error ((stream stream) error-number context)
271  (error 'simple-stream-error :stream stream
272         :format-control (format nil "~a during ~a"
273                                 (%strerror error-number) context)))
274
275
276
277(defmethod stream-write-char ((stream stream) char)
278  (declare (ignore char))
279  (error "stream ~S is not capable of output" stream))
280
281(defun stream-write-entire-string (stream string)
282  (stream-write-string stream string))
283
284
285(defmethod stream-read-char ((x t))
286  (report-bad-arg x 'stream))
287
288(defmethod stream-read-char ((stream stream))
289  (error "~s is not capable of input" stream))
290
291(defmethod stream-unread-char ((x t) char)
292  (declare (ignore char))
293  (report-bad-arg x 'stream))
294
295(defmethod stream-unread-char ((stream stream) char)
296  (declare (ignore char))
297  (error "stream ~S is not capable of input" stream))
298
299
300
301(defmethod stream-force-output ((stream output-stream)) nil)
302(defmethod stream-maybe-force-output ((stream stream))
303  (stream-force-output stream))
304
305(defmethod stream-finish-output ((stream output-stream)) nil)
306
307
308
309(defmethod stream-clear-output ((stream output-stream)) nil)
310
311(defmethod close ((stream stream) &key abort)
312  (declare (ignore abort))
313  (open-stream-p stream))
314
315(defmethod close-for-termination ((stream stream) abort)
316  (close stream :abort abort))
317
318
319(defmethod open-stream-p ((x t))
320  (report-bad-arg x 'stream))
321
322(defmethod open-stream-p ((stream stream))
323  t)
324
325(defmethod stream-external-format ((x t))
326  (report-bad-arg x 'stream))
327
328(defmethod stream-external-format ((s stream))
329  nil)
330
331
332(defmethod (setf stream-external-format) (new (s t))
333  (normalize-external-format (stream-domain s) new)
334  (report-bad-arg s 'stream))
335
336
337
338   
339(defmethod stream-fresh-line ((stream output-stream))
340  (terpri stream)
341  t)
342
343(defmethod stream-line-length ((stream stream))
344  "This is meant to be shadowed by particular kinds of streams,
345   esp those associated with windows."
346  80)
347
348(defmethod interactive-stream-p ((x t))
349  (report-bad-arg x 'stream))
350
351(defmethod interactive-stream-p ((stream stream)) nil)
352
353(defmethod stream-clear-input ((x t))
354  (report-bad-arg x 'stream))
355
356(defmethod stream-clear-input ((stream input-stream)) nil)
357
358(defmethod stream-listen ((stream input-stream))
359  (not (eofp stream)))
360
361(defmethod stream-filename ((stream stream))
362  (report-bad-arg stream 'file-stream))
363
364
365
366
367;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
368
369;;; For input streams, the IO-BUFFER-COUNT field denotes the number
370;;; of elements read from the underlying input source (e.g., the
371;;; file system.)  For output streams, it's the high-water mark of
372;;; elements output to the buffer.
373
374(defstruct io-buffer
375               ;; This type is too complex during bootstrapping.
376  (buffer nil #|:type (or (simple-array * (*)) null)|#)
377  (bufptr nil :type (or macptr null))
378  (size 0 :type fixnum)                 ; size (in octets) of buffer
379  (idx 0 :type fixnum)                  ; index of next element
380  (count 0 :type fixnum)                ; count of active elements
381  (limit 0 :type fixnum)                ; size (in elements) of buffer
382  (translate nil)                       ; newline-translation
383  )
384
385(defmethod print-object ((buf io-buffer) out)
386  (print-unreadable-object (buf out :identity t :type t)
387    (let* ((buffer (io-buffer-buffer buf)))
388      (when buffer (format out " ~s " (array-element-type buffer))))
389    (format out "~d/~d/~d"
390            (io-buffer-idx buf)
391            (io-buffer-count buf)
392            (io-buffer-limit buf))))
393
394(defstruct ioblock
395  stream                                ; the stream being buffered
396  untyi-char                            ; nil or last value passed to
397                                        ;  stream-unread-char
398  (inbuf nil :type (or null io-buffer))
399  (outbuf nil :type (or null io-buffer))
400  (element-type 'character)
401  (element-shift 0 :type fixnum)        ;element shift count
402  (charpos 0 :type (or null fixnum))     ;position of cursor
403  (device -1 :type (or null fixnum))     ;file descriptor
404  (advance-function 'ioblock-advance)
405  (listen-function 'ioblock-listen)
406  (eofp-function 'ioblock-eofp)
407  (force-output-function 'ioblock-force-output)
408  (close-function 'ioblock-close)
409  (inbuf-lock nil)
410  (eof nil)
411  (interactive nil)
412  (dirty nil)
413  (outbuf-lock nil)
414  (owner nil)
415  (read-char-function 'ioblock-no-char-input)
416  (read-byte-function 'ioblock-no-binary-input)
417  (write-byte-function 'ioblock-no-binary-output)
418  (write-char-function 'ioblock-no-char-output)
419  (encoding nil)
420  (pending-byte-order-mark nil)
421  (decode-literal-code-unit-limit 256)
422  (encode-output-function nil)
423  (decode-input-function nil)
424  (read-char-when-locked-function 'ioblock-no-char-input)
425  (write-simple-string-function 'ioblock-no-char-output)
426  (character-read-vector-function 'ioblock-no-char-input)
427  (read-line-function 'ioblock-no-char-input)
428  (write-char-when-locked-function 'ioblock-no-char-output)
429  (read-byte-when-locked-function 'ioblock-no-binary-input)
430  (write-byte-when-locked-function 'ioblock-no-binary-output)
431  (peek-char-function 'ioblock-no-char-input)
432  (native-byte-order t)
433  (read-char-without-translation-when-locked-function 'ioblock-no-char-input)
434  (write-char-without-translation-when-locked-function 'iblock-no-char-output)
435  (sharing nil)
436  (line-termination nil)
437  (unread-char-function 'ioblock-no-char-input)
438  (encode-literal-char-code-limit 256)
439  (input-timeout nil)
440  (output-timeout nil)
441  (deadline nil))
442
443
444;;; Functions on ioblocks.  So far, we aren't saying anything
445;;; about how streams use them.
446
447(defun ioblock-no-binary-input (ioblock &rest otters)
448  (declare (ignore otters))
449  (report-bad-arg (ioblock-stream ioblock) '(and binary-stream input-stream)))
450
451(defun ioblock-no-binary-output (ioblock &rest others)
452  (declare (ignore others))
453  (report-bad-arg (ioblock-stream ioblock) '(and binary-stream output-stream)))
454
455(defun ioblock-no-char-input (ioblock &rest others)
456  (declare (ignore others))
457  (report-bad-arg (ioblock-stream ioblock) '(and character-stream input-stream)))
458
459(defun ioblock-no-char-output (ioblock &rest others)
460  (declare (ignore others))
461  (report-bad-arg (ioblock-stream ioblock) '(and character-stream output-stream)))
462
463
464(defun ioblock-octets-to-elements (ioblock octets)
465  (let* ((shift (ioblock-element-shift ioblock)))
466    (declare (fixnum shift))
467    (if (zerop shift)
468      octets
469      (ash octets (- shift)))))
470
471(defun ioblock-elements-to-octets (ioblock elements)
472  (let* ((shift (ioblock-element-shift ioblock)))
473    (declare (fixnum shift))
474    (if (zerop shift)
475      elements
476      (ash elements shift))))
477
478
479
480;;; ioblock must really be an ioblock or you will crash
481;;; Also: the expression "ioblock" is evaluated multiple times.
482
483(declaim (inline check-ioblock-owner))
484(defun check-ioblock-owner (ioblock)
485  (declare (optimize (speed 3)))
486  (let* ((owner (ioblock-owner ioblock)))
487    (if owner
488      (or (eq owner *current-process*)
489          (error "Stream ~s is private to ~s" (ioblock-stream ioblock) owner)))))
490
491
492
493(declaim (inline %ioblock-advance))
494(defun %ioblock-advance (ioblock read-p)
495  (funcall (ioblock-advance-function ioblock)
496           (ioblock-stream ioblock)
497           ioblock
498           read-p))
499
500
501(defun %ioblock-surrounding-characters (ioblock)
502  (let* ((inbuf (ioblock-inbuf ioblock)))
503    (when inbuf
504      (let* ((encoding (or (ioblock-encoding ioblock)
505                           (get-character-encoding nil)))
506             (size (ash (character-encoding-code-unit-size encoding) -3))
507             (buffer (io-buffer-buffer inbuf))
508             (idx (io-buffer-idx inbuf))
509             (count (io-buffer-count inbuf)))
510        (unless (= count 0)
511          (let* ((start (max (- idx (* 5 size)) 0))
512                 (end (min (+ idx (* 5 size)) count))
513                 (string (make-string (funcall (character-encoding-length-of-vector-encoding-function encoding) buffer start end))))
514            (funcall (character-encoding-vector-decode-function encoding)
515                     buffer
516                     start
517                     (- end start)
518                     string)
519            (if (position #\Replacement_Character string)
520              (string-trim (string #\Replacement_Character) string)
521              string)))))))
522             
523       
524
525
526(defun %bivalent-ioblock-read-u8-byte (ioblock)
527  (declare (optimize (speed 3) (safety 0)))
528  (setf (ioblock-untyi-char ioblock) nil)
529  (let* ((buf (ioblock-inbuf ioblock))
530         (idx (io-buffer-idx buf))
531         (limit (io-buffer-count buf)))
532    (declare (fixnum idx limit))
533    (when (= idx limit)
534      (unless (%ioblock-advance ioblock t)
535        (return-from %bivalent-ioblock-read-u8-byte :eof))
536      (setq idx (io-buffer-idx buf)
537            limit (io-buffer-count buf)))
538    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
539    (aref (the (simple-array (unsigned-byte 8) (*))
540              (io-buffer-buffer buf)) idx)))
541
542
543(declaim (inline %ioblock-read-u8-byte))
544(defun %ioblock-read-u8-byte (ioblock)
545  (declare (optimize (speed 3) (safety 0)))
546  (let* ((buf (ioblock-inbuf ioblock))
547         (idx (io-buffer-idx buf))
548         (limit (io-buffer-count buf)))
549    (declare (fixnum idx limit))
550    (when (= idx limit)
551      (unless (%ioblock-advance ioblock t)
552        (return-from %ioblock-read-u8-byte :eof))
553      (setq idx (io-buffer-idx buf)))
554    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
555    (aref (the (simple-array (unsigned-byte 8) (*))
556            (io-buffer-buffer buf)) idx)))
557
558(declaim (inline %ioblock-read-u8-code-unit))
559(defun %ioblock-read-u8-code-unit (ioblock)
560  (declare (optimize (speed 3) (safety 0)))
561  (let* ((buf (ioblock-inbuf ioblock))
562         (idx (io-buffer-idx buf))
563         (limit (io-buffer-count buf)))
564    (declare (fixnum idx limit))
565    (when (= idx limit)
566      (unless (%ioblock-advance ioblock t)
567        (return-from %ioblock-read-u8-code-unit :eof))
568      (setq idx (io-buffer-idx buf)
569            limit (io-buffer-count buf)))
570    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
571    (aref (the (simple-array (unsigned-byte 8) (*))
572              (io-buffer-buffer buf)) idx)))             
573
574(declaim (inline %ioblock-read-s8-byte))
575(defun %ioblock-read-s8-byte (ioblock)
576  (declare (optimize (speed 3) (safety 0)))
577  (let* ((buf (ioblock-inbuf ioblock))
578         (idx (io-buffer-idx buf))
579         (limit (io-buffer-count buf)))
580    (declare (fixnum idx limit))
581    (when (= idx limit)
582      (unless (%ioblock-advance ioblock t)
583        (return-from %ioblock-read-s8-byte :eof))
584      (setq idx (io-buffer-idx buf)
585            limit (io-buffer-count buf)))
586    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
587    (aref (the (simple-array (signed-byte 8) (*))
588            (io-buffer-buffer buf)) idx)))
589
590(defun %private-ioblock-read-s8-byte (ioblock)
591  (declare (optimize (speed 3) (safety 0)))
592  (check-ioblock-owner ioblock)
593  (%ioblock-read-s8-byte ioblock))
594
595(defun %locked-ioblock-read-s8-byte (ioblock)
596  (declare (optimize (speed 3) (safety 0)))
597  (with-ioblock-input-lock-grabbed (ioblock)
598    (%ioblock-read-s8-byte ioblock)))
599
600
601(declaim (inline %ioblock-read-u16-byte))
602(defun %ioblock-read-u16-byte (ioblock)
603  (declare (optimize (speed 3) (safety 0)))
604  (let* ((buf (ioblock-inbuf ioblock))
605         (idx (io-buffer-idx buf))
606         (limit (io-buffer-count buf)))
607    (declare (fixnum idx limit))
608    (when (= idx limit)
609      (unless (%ioblock-advance ioblock t)
610        (return-from %ioblock-read-u16-byte :eof))
611      (setq idx (io-buffer-idx buf)
612            limit (io-buffer-count buf)))
613    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
614    (aref (the (simple-array (unsigned-byte 16) (*))
615            (io-buffer-buffer buf)) idx)))
616
617(defun %private-ioblock-read-u16-byte (ioblock)
618  (declare (optimize (speed 3) (safety 0)))
619  (check-ioblock-owner ioblock)
620  (%ioblock-read-u16-byte ioblock))
621
622(defun %locked-ioblock-read-u16-byte (ioblock)
623  (declare (optimize (speed 3) (safety 0)))
624  (with-ioblock-input-lock-grabbed (ioblock)
625    (%ioblock-read-u16-byte ioblock)))
626
627(declaim (inline %ioblock-read-s16-byte))
628(defun %ioblock-read-s16-byte (ioblock)
629  (declare (optimize (speed 3) (safety 0)))
630  (let* ((buf (ioblock-inbuf ioblock))
631         (idx (io-buffer-idx buf))
632         (limit (io-buffer-count buf)))
633    (declare (fixnum idx limit))
634    (when (= idx limit)
635      (unless (%ioblock-advance ioblock t)
636        (return-from %ioblock-read-s16-byte :eof))
637      (setq idx (io-buffer-idx buf)
638            limit (io-buffer-count buf)))
639    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
640    (aref (the (simple-array (signed-byte 16) (*))
641            (io-buffer-buffer buf)) idx)))
642
643(defun %private-ioblock-read-s16-byte (ioblock)
644  (declare (optimize (speed 3) (safety 0)))
645  (check-ioblock-owner ioblock)
646  (%ioblock-read-s16-byte ioblock))
647
648(defun %locked-ioblock-read-s16-byte (ioblock)
649  (declare (optimize (speed 3) (safety 0)))
650  (with-ioblock-input-lock-grabbed (ioblock)
651    (%ioblock-read-s16-byte ioblock)))
652
653
654(declaim (inline %ioblock-read-u32-byte))
655(defun %ioblock-read-u32-byte (ioblock)
656  (declare (optimize (speed 3) (safety 0)))
657  (let* ((buf (ioblock-inbuf ioblock))
658         (idx (io-buffer-idx buf))
659         (limit (io-buffer-count buf)))
660    (declare (fixnum idx limit))
661    (when (= idx limit)
662      (unless (%ioblock-advance ioblock t)
663        (return-from %ioblock-read-u32-byte :eof))
664      (setq idx (io-buffer-idx buf)
665            limit (io-buffer-count buf)))
666    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
667    (aref (the (simple-array (unsigned-byte 32) (*))
668            (io-buffer-buffer buf)) idx)))
669
670(defun %private-ioblock-read-u32-byte (ioblock)
671  (check-ioblock-owner ioblock)
672  (%ioblock-read-u32-byte ioblock))
673
674(defun %locked-ioblock-read-u32-byte (ioblock)
675  (with-ioblock-input-lock-grabbed (ioblock)
676    (%ioblock-read-u32-byte ioblock)))
677
678(declaim (inline %ioblock-read-s32-byte))
679(defun %ioblock-read-s32-byte (ioblock)
680  (declare (optimize (speed 3) (safety 0)))
681  (let* ((buf (ioblock-inbuf ioblock))
682         (idx (io-buffer-idx buf))
683         (limit (io-buffer-count buf)))
684    (declare (fixnum idx limit))
685    (when (= idx limit)
686      (unless (%ioblock-advance ioblock t)
687        (return-from %ioblock-read-s32-byte :eof))
688      (setq idx (io-buffer-idx buf)
689            limit (io-buffer-count buf)))
690    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
691    (aref (the (simple-array (signed-byte 32) (*))
692            (io-buffer-buffer buf)) idx)))
693
694(defun %private-ioblock-read-s32-byte (ioblock)
695  (check-ioblock-owner ioblock)
696  (%ioblock-read-s32-byte ioblock))
697
698(defun %locked-ioblock-read-s32-byte (ioblock)
699  (with-ioblock-input-lock-grabbed (ioblock)
700    (%ioblock-read-s32-byte ioblock)))
701
702#+64-bit-target
703(progn
704(declaim (inline %ioblock-read-u64-byte))
705(defun %ioblock-read-u64-byte (ioblock)
706  (declare (optimize (speed 3) (safety 0)))
707  (let* ((buf (ioblock-inbuf ioblock))
708         (idx (io-buffer-idx buf))
709         (limit (io-buffer-count buf)))
710    (declare (fixnum idx limit))
711    (when (= idx limit)
712      (unless (%ioblock-advance ioblock t)
713        (return-from %ioblock-read-u64-byte :eof))
714      (setq idx (io-buffer-idx buf)
715            limit (io-buffer-count buf)))
716    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
717    (aref (the (simple-array (unsigned-byte 64) (*))
718            (io-buffer-buffer buf)) idx)))
719
720(defun %private-ioblock-read-u64-byte (ioblock)
721  (declare (optimize (speed 3) (safety 0)))
722  (check-ioblock-owner ioblock)
723  (%ioblock-read-u64-byte ioblock))
724
725(defun %locked-ioblock-read-u64-byte (ioblock)
726  (declare (optimize (speed 3) (safety 0)))
727  (with-ioblock-input-lock-grabbed (ioblock)
728    (%ioblock-read-u64-byte ioblock)))
729
730(defun %ioblock-read-s64-byte (ioblock)
731  (declare (optimize (speed 3) (safety 0)))
732  (let* ((buf (ioblock-inbuf ioblock))
733         (idx (io-buffer-idx buf))
734         (limit (io-buffer-count buf)))
735    (declare (fixnum idx limit))
736    (when (= idx limit)
737      (unless (%ioblock-advance ioblock t)
738        (return-from %ioblock-read-s64-byte :eof))
739      (setq idx (io-buffer-idx buf)
740            limit (io-buffer-count buf)))
741    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
742    (aref (the (simple-array (signed-byte 64) (*))
743            (io-buffer-buffer buf)) idx)))
744
745(defun %private-ioblock-read-s64-byte (ioblock)
746  (declare (optimize (speed 3) (safety 0)))
747  (check-ioblock-owner ioblock)
748  (%ioblock-read-s64-byte ioblock))
749
750(defun %locked-ioblock-read-s64-byte (ioblock)
751  (declare (optimize (speed 3) (safety 0)))
752  (with-ioblock-input-lock-grabbed (ioblock)
753    (%ioblock-read-s64-byte ioblock)))
754)
755
756
757;;; Read a 16-bit code element from a stream with element-type
758;;; (UNSIGNED-BYTE 8), in native byte-order.
759
760(declaim (inline %ioblock-read-u16-code-unit))
761(defun %ioblock-read-u16-code-unit (ioblock)
762  (declare (optimize (speed 3) (safety 0)))
763  (let* ((buf (ioblock-inbuf ioblock))
764         (idx (io-buffer-idx buf))
765         (limit (io-buffer-count buf))
766         (vector (io-buffer-buffer buf)))
767    (declare (fixnum idx limit)
768             (type (simple-array (unsigned-byte 8) (*)) vector))
769    (if (<= (the fixnum (+ idx 2)) limit)
770      (let* ((b0 (aref vector idx))
771             (b1 (aref vector (the fixnum (1+ idx)))))
772        (declare (type (unsigned-byte 8) b0 b1))
773        (setf (io-buffer-idx buf) (the fixnum (+ idx 2)))
774        #+big-endian-target
775        (logior (the (unsigned-byte 16) (ash b0 8)) b1)
776        #+little-endian-target
777        (logior (the (unsigned-byte 16) (ash b1 8)) b0))
778      (if (< idx limit)
779        (let* ((b0 (aref vector idx))
780               (n (%ioblock-advance ioblock t)))
781          (declare (type (unsigned-byte 8) b0))
782          (if (null n)
783            :eof
784            (let* ((b1 (aref vector 0)))
785              (declare (type (unsigned-byte 8) b1))
786              (setf (io-buffer-idx buf) 1)
787              #+big-endian-target
788              (logior (the (unsigned-byte 16) (ash b0 8)) b1)
789              #+little-endian-target
790              (logior (the (unsigned-byte 16) (ash b1 8)) b0))))
791        (let* ((n (%ioblock-advance ioblock t)))
792          (if (null n)
793            :eof
794            (if (eql n 1)
795              (progn
796                (setf (io-buffer-idx buf) 1)
797                :eof)
798              (let* ((b0 (aref vector 0))
799                     (b1 (aref vector 1)))
800                (declare (type (unsigned-byte 8) b0 b1))
801                (setf (io-buffer-idx buf) 2)
802                #+big-endian-target
803                (logior (the (unsigned-byte 16) (ash b0 8)) b1)
804                #+little-endian-target
805                (logior (the (unsigned-byte 16) (ash b1 8)) b0)))))))))
806 
807(declaim (inline %ioblock-read-swapped-u16-code-unit))
808(defun %ioblock-read-swapped-u16-code-unit (ioblock)
809  (declare (optimize (speed 3) (safety 0)))
810    (let* ((buf (ioblock-inbuf ioblock))
811         (idx (io-buffer-idx buf))
812         (limit (io-buffer-count buf))
813         (vector (io-buffer-buffer buf)))
814    (declare (fixnum idx limit)
815             (type (simple-array (unsigned-byte 8) (*)) vector))
816    (if (<= (the fixnum (+ idx 2)) limit)
817      (let* ((b0 (aref vector idx))
818             (b1 (aref vector (the fixnum (1+ idx)))))
819        (declare (type (unsigned-byte 8) b0 b1))
820        (setf (io-buffer-idx buf) (the fixnum (+ idx 2)))
821        #+little-endian-target
822        (logior (the (unsigned-byte 16) (ash b0 8)) b1)
823        #+big-endian-target
824        (logior (the (unsigned-byte 16) (ash b1 8)) b0))
825      (if (< idx limit)
826        (let* ((b0 (aref vector idx))
827               (n (%ioblock-advance ioblock t)))
828          (declare (type (unsigned-byte 8) b0))
829          (if (null n)
830            :eof
831            (let* ((b1 (aref vector 0)))
832              (declare (type (unsigned-byte 8) b1))
833              (setf (io-buffer-idx buf) 1)
834              #+little-endian-target
835              (logior (the (unsigned-byte 16) (ash b0 8)) b1)
836              #+big-endian-target
837              (logior (the (unsigned-byte 16) (ash b1 8)) b0))))
838        (let* ((n (%ioblock-advance ioblock t)))
839          (if (null n)
840            :eof
841            (if (eql n 1)
842              (progn
843                (setf (io-buffer-idx buf) 1)
844                :eof)
845              (let* ((b0 (aref vector 0))
846                     (b1 (aref vector 1)))
847                (declare (type (unsigned-byte 8) b0 b1))
848                (setf (io-buffer-idx buf) 2)
849                #+little-endian-target
850                (logior (the (unsigned-byte 16) (ash b0 8)) b1)
851                #+big-endian-target
852                (logior (the (unsigned-byte 16) (ash b1 8)) b0)))))))))
853
854
855(declaim (inline %ioblock-read-u32-code-unit))
856(defun %ioblock-read-u32-code-unit (ioblock)
857  (declare (optimize (speed 3) (safety 0)))
858  (let* ((buf (ioblock-inbuf ioblock))
859         (idx (io-buffer-idx buf))
860         (limit (io-buffer-count buf))
861         (vector (io-buffer-buffer buf)))
862    (declare (fixnum idx limit)
863             (type (simple-array (unsigned-byte 8) (*)) vector))
864    (cond ((<= (the fixnum (+ idx 4)) limit)
865           (let* ((b0 (aref vector idx))
866                  (b1 (aref vector (the fixnum (1+ idx))))
867                  (b2 (aref vector (the fixnum (+ idx 2))))
868                  (b3 (aref vector (the fixnum (+ idx 3)))))
869             (declare (type (unsigned-byte 8) b0 b1 b2 b3))
870             (setf (io-buffer-idx buf) (the fixnum (+ idx 4)))
871             #+big-endian-target
872             (logior (the (unsigned-byte 32) (ash b0 24))
873                     (the (unsigned-byte 24) (ash b1 16))
874                     (the (unsigned-byte 16) (ash b2 8))
875                     b3)
876             #+little-endian-target
877             (logior (the (unsigned-byte 32) (ash b3 24))
878                     (the (unsigned-byte 24) (ash b2 16))
879                     (the (unsigned-byte 16) (ash b1 8))
880                     b0)))
881          ((= (the fixnum (+ idx 3)) limit)
882           (let* ((b0 (aref vector idx))
883                  (b1 (aref vector (the fixnum (1+ idx))))
884                  (b2 (aref vector (the fixnum (+ idx 2))))
885                  (n (%ioblock-advance ioblock t)))
886             (declare (type (unsigned-byte 8) b0 b1 b2))
887             (if (null n)
888               :eof
889               (let* ((b3 (aref vector 0)))
890                 (declare (type (unsigned-byte 8) b3))
891                 (setf (io-buffer-idx buf) 1)
892                 #+big-endian-target
893                 (logior (the (unsigned-byte 32) (ash b0 24))
894                         (the (unsigned-byte 24) (ash b1 16))
895                         (the (unsigned-byte 16) (ash b2 8))
896                         b3)
897                 #+little-endian-target
898                 (logior (the (unsigned-byte 32) (ash b3 24))
899                         (the (unsigned-byte 24) (ash b2 16))
900                         (the (unsigned-byte 16) (ash b1 8))
901                         b0)))))
902          ((= (the fixnum (+ idx 2)) limit)
903           (let* ((b0 (aref vector idx))
904                  (b1 (aref vector (the fixnum (1+ idx))))
905                  (n (%ioblock-advance ioblock t)))
906             (declare (type (unsigned-byte 8) b0 b1))
907             (if (null n)
908               :eof
909               (if (eql n 1)
910                 (progn
911                   (setf (io-buffer-idx buf) 1)
912                   :eof)
913                 (let* ((b2 (aref vector 0))
914                        (b3 (aref vector 1)))
915                   (declare (type (unsigned-byte 8) b2 b3))
916                   (setf (io-buffer-idx buf) 2)
917                   #+big-endian-target
918                   (logior (the (unsigned-byte 32) (ash b0 24))
919                           (the (unsigned-byte 24) (ash b1 16))
920                           (the (unsigned-byte 16) (ash b2 8))
921                           b3)
922                   #+little-endian-target
923                   (logior (the (unsigned-byte 32) (ash b3 24))
924                           (the (unsigned-byte 24) (ash b2 16))
925                           (the (unsigned-byte 16) (ash b1 8))
926                           b0))))))
927          ((= (the fixnum (1+ idx)) limit)
928           (let* ((b0 (aref vector idx))
929                  (n (%ioblock-advance ioblock t)))
930             (declare (type (unsigned-byte 8) b0))
931             (if (null n)
932               :eof
933               (if (< n 3)
934                 (progn
935                   (setf (io-buffer-idx buf) n)
936                   :eof)
937                 (let* ((b1 (aref vector 0))
938                        (b2 (aref vector 1))
939                        (b3 (aref vector 2)))
940                   (setf (io-buffer-idx buf) 3)
941                   #+big-endian-target
942                   (logior (the (unsigned-byte 32) (ash b0 24))
943                           (the (unsigned-byte 24) (ash b1 16))
944                           (the (unsigned-byte 16) (ash b2 8))
945                           b3)
946                   #+little-endian-target
947                   (logior (the (unsigned-byte 32) (ash b3 24))
948                           (the (unsigned-byte 24) (ash b2 16))
949                           (the (unsigned-byte 16) (ash b1 8))
950                           b0))))))
951          (t
952           (let* ((n (%ioblock-advance ioblock t)))
953             (if (null n)
954               :eof
955               (if (< n 4)
956                 (progn
957                   (setf (io-buffer-idx buf) n)
958                   :eof)
959                 (let* ((b0 (aref vector 0))
960                        (b1 (aref vector 1))
961                        (b2 (aref vector 2))
962                        (b3 (aref vector 3)))
963                (declare (type (unsigned-byte 8) b0 b1 b2 b3))
964                (setf (io-buffer-idx buf) 4)
965                #+big-endian-target
966                (logior (the (unsigned-byte 32) (ash b0 24))
967                        (the (unsigned-byte 24) (ash b1 16))
968                        (the (unsigned-byte 16) (ash b2 8))
969                        b3)
970                #+little-endian-target
971                (logior (the (unsigned-byte 32) (ash b3 24))
972                        (the (unsigned-byte 24) (ash b2 16))
973                        (the (unsigned-byte 16) (ash b1 8))
974                        b0)))))))))
975
976(declaim (inline %ioblock-read-swapped-u32-code-unit))
977(defun %ioblock-read-swapped-u32-code-unit (ioblock)
978  (declare (optimize (speed 3) (safety 0)))
979  (let* ((buf (ioblock-inbuf ioblock))
980         (idx (io-buffer-idx buf))
981         (limit (io-buffer-count buf))
982         (vector (io-buffer-buffer buf)))
983    (declare (fixnum idx limit)
984             (type (simple-array (unsigned-byte 8) (*)) vector))
985    (cond ((<= (the fixnum (+ idx 4)) limit)
986           (let* ((b0 (aref vector idx))
987                  (b1 (aref vector (the fixnum (1+ idx))))
988                  (b2 (aref vector (the fixnum (+ idx 2))))
989                  (b3 (aref vector (the fixnum (+ idx 3)))))
990             (declare (type (unsigned-byte 8) b0 b1 b2 b3))
991             (setf (io-buffer-idx buf) (the fixnum (+ idx 4)))
992             #+little-endian-target
993             (logior (the (unsigned-byte 32) (ash b0 24))
994                     (the (unsigned-byte 24) (ash b1 16))
995                     (the (unsigned-byte 16) (ash b2 8))
996                     b3)
997             #+big-endian-target
998             (logior (the (unsigned-byte 32) (ash b3 24))
999                     (the (unsigned-byte 24) (ash b2 16))
1000                     (the (unsigned-byte 16) (ash b1 8))
1001                     b0)))
1002          ((= (the fixnum (+ idx 3)) limit)
1003           (let* ((b0 (aref vector idx))
1004                  (b1 (aref vector (the fixnum (1+ idx))))
1005                  (b2 (aref vector (the fixnum (+ idx 2))))
1006                  (n (%ioblock-advance ioblock t)))
1007             (declare (type (unsigned-byte 8) b0 b1 b2))
1008             (if (null n)
1009               :eof
1010               (let* ((b3 (aref vector 0)))
1011                 (declare (type (unsigned-byte 8) b3))
1012                 (setf (io-buffer-idx buf) 1)
1013                 #+little-endian-target
1014                 (logior (the (unsigned-byte 32) (ash b0 24))
1015                         (the (unsigned-byte 24) (ash b1 16))
1016                         (the (unsigned-byte 16) (ash b2 8))
1017                         b3)
1018                 #+big-endian-target
1019                 (logior (the (unsigned-byte 32) (ash b3 24))
1020                         (the (unsigned-byte 24) (ash b2 16))
1021                         (the (unsigned-byte 16) (ash b1 8))
1022                         b0)))))
1023          ((= (the fixnum (+ idx 2)) limit)
1024           (let* ((b0 (aref vector idx))
1025                  (b1 (aref vector (the fixnum (1+ idx))))
1026                  (n (%ioblock-advance ioblock t)))
1027             (declare (type (unsigned-byte 8) b0 b1))
1028             (if (null n)
1029               :eof
1030               (if (eql n 1)
1031                 (progn
1032                   (setf (io-buffer-idx buf) 1)
1033                   :eof)
1034                 (let* ((b2 (aref vector 0))
1035                        (b3 (aref vector 1)))
1036                   (declare (type (unsigned-byte 8) b2 b3))
1037                   (setf (io-buffer-idx buf) 2)
1038                   #+little-endian-target
1039                   (logior (the (unsigned-byte 32) (ash b0 24))
1040                           (the (unsigned-byte 24) (ash b1 16))
1041                           (the (unsigned-byte 16) (ash b2 8))
1042                           b3)
1043                   #+big-endian-target
1044                   (logior (the (unsigned-byte 32) (ash b3 24))
1045                           (the (unsigned-byte 24) (ash b2 16))
1046                           (the (unsigned-byte 16) (ash b1 8))
1047                           b0))))))
1048          ((= (the fixnum (1+ idx)) limit)
1049           (let* ((b0 (aref vector idx))
1050                  (n (%ioblock-advance ioblock t)))
1051             (declare (type (unsigned-byte 8) b0))
1052             (if (null n)
1053               :eof
1054               (if (< n 3)
1055                 (progn
1056                   (setf (io-buffer-idx buf) n)
1057                   :eof)
1058                 (let* ((b1 (aref vector 0))
1059                        (b2 (aref vector 1))
1060                        (b3 (aref vector 2)))
1061                   (setf (io-buffer-idx buf) 3)
1062                   #+little-endian-target
1063                   (logior (the (unsigned-byte 32) (ash b0 24))
1064                           (the (unsigned-byte 24) (ash b1 16))
1065                           (the (unsigned-byte 16) (ash b2 8))
1066                           b3)
1067                   #+big-endian-target
1068                   (logior (the (unsigned-byte 32) (ash b3 24))
1069                           (the (unsigned-byte 24) (ash b2 16))
1070                           (the (unsigned-byte 16) (ash b1 8))
1071                           b0))))))
1072          (t
1073           (let* ((n (%ioblock-advance ioblock t)))
1074             (if (null n)
1075               :eof
1076               (if (< n 4)
1077                 (progn
1078                   (setf (io-buffer-idx buf) n)
1079                   :eof)
1080                 (let* ((b0 (aref vector 0))
1081                        (b1 (aref vector 1))
1082                        (b2 (aref vector 2))
1083                        (b3 (aref vector 3)))
1084                (declare (type (unsigned-byte 8) b0 b1 b2 b3))
1085                (setf (io-buffer-idx buf) 4)
1086                #+little-endian-target
1087                (logior (the (unsigned-byte 32) (ash b0 24))
1088                        (the (unsigned-byte 24) (ash b1 16))
1089                        (the (unsigned-byte 16) (ash b2 8))
1090                        b3)
1091                #+big-endian-target
1092                (logior (the (unsigned-byte 32) (ash b3 24))
1093                        (the (unsigned-byte 24) (ash b2 16))
1094                        (the (unsigned-byte 16) (ash b1 8))
1095                        b0)))))))))
1096
1097
1098(defun %bivalent-private-ioblock-read-u8-byte (ioblock)
1099  (declare (optimize (speed 3) (safety 0)))
1100  (check-ioblock-owner ioblock)
1101  (setf (ioblock-untyi-char ioblock) nil)
1102    (let* ((buf (ioblock-inbuf ioblock))
1103           (idx (io-buffer-idx buf))
1104           (limit (io-buffer-count buf)))
1105      (declare (fixnum idx limit))
1106      (when (= idx limit)
1107        (unless (%ioblock-advance ioblock t)
1108          (return-from %bivalent-private-ioblock-read-u8-byte :eof))
1109        (setq idx (io-buffer-idx buf)
1110              limit (io-buffer-count buf)))
1111      (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
1112      (aref (the (simple-array (unsigned-byte 8) (*))
1113              (io-buffer-buffer buf)) idx)))
1114
1115(defun %private-ioblock-read-u8-byte (ioblock)
1116  (declare (optimize (speed 3) (safety 0)))
1117  (check-ioblock-owner ioblock)
1118  (%ioblock-read-u8-byte ioblock))
1119
1120(defun %bivalent-locked-ioblock-read-u8-byte (ioblock)
1121  (declare (optimize (speed 3) (safety 0)))
1122  (with-ioblock-input-lock-grabbed (ioblock)
1123    (setf (ioblock-untyi-char ioblock) nil)
1124    (let* ((buf (ioblock-inbuf ioblock))
1125           (idx (io-buffer-idx buf))
1126           (limit (io-buffer-count buf)))
1127      (declare (fixnum idx limit))
1128      (when (= idx limit)
1129        (unless (%ioblock-advance ioblock t)
1130          (return-from %bivalent-locked-ioblock-read-u8-byte :eof))
1131        (setq idx (io-buffer-idx buf)
1132              limit (io-buffer-count buf)))
1133      (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
1134      (aref (the (simple-array (unsigned-byte 8) (*))
1135              (io-buffer-buffer buf)) idx))))
1136
1137(defun %locked-ioblock-read-u8-byte (ioblock)
1138  (declare (optimize (speed 3) (safety 0)))
1139  (with-ioblock-input-lock-grabbed (ioblock)
1140    (%ioblock-read-u8-byte ioblock)))
1141
1142(defun %general-ioblock-read-byte (ioblock)
1143  (declare (optimize (speed 3) (safety 0)))
1144  (with-ioblock-input-locked (ioblock)
1145    (let* ((buf (ioblock-inbuf ioblock))
1146           (idx (io-buffer-idx buf))
1147           (limit (io-buffer-count buf)))
1148      (declare (fixnum idx limit))
1149      (when (= idx limit)
1150        (unless (%ioblock-advance ioblock t)
1151          (return-from %general-ioblock-read-byte :eof))
1152        (setq idx (io-buffer-idx buf)
1153              limit (io-buffer-count buf)))
1154      (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
1155      (uvref (io-buffer-buffer buf) idx))))
1156
1157
1158(declaim (inline %ioblock-tyi))
1159(defun %ioblock-tyi (ioblock)
1160  (declare (optimize (speed 3) (safety 0)))
1161  (let* ((ch (ioblock-untyi-char ioblock)))
1162    (if ch
1163      (prog1 ch
1164        (setf (ioblock-untyi-char ioblock) nil))
1165      (let* ((buf (ioblock-inbuf ioblock))
1166             (idx (io-buffer-idx buf))
1167             (limit (io-buffer-count buf)))
1168        (declare (fixnum idx limit))
1169        (when (= idx limit)
1170          (unless (%ioblock-advance ioblock t)
1171            (return-from %ioblock-tyi :eof))
1172          (setq idx 0))
1173        (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
1174        (%code-char (aref (the (simple-array (unsigned-byte 8) (*))
1175                                       (io-buffer-buffer buf)) idx))))))
1176
1177(defun %private-ioblock-tyi (ioblock)
1178  (declare (optimize (speed 3) (safety 0)))
1179  (check-ioblock-owner ioblock)
1180  (%ioblock-tyi ioblock))
1181
1182(defun %locked-ioblock-tyi (ioblock)
1183  (declare (optimize (speed 3) (safety 0)))
1184  (with-ioblock-input-lock-grabbed (ioblock)
1185    (%ioblock-tyi ioblock)))
1186
1187;;; Read a character composed of one or more 8-bit code-units.
1188(declaim (inline %ioblock-read-u8-encoded-char))
1189(defun %ioblock-read-u8-encoded-char (ioblock)
1190  (declare (optimize (speed 3) (safety 0)))
1191  (let* ((ch (ioblock-untyi-char ioblock)))
1192    (if ch
1193      (prog1 ch
1194        (setf (ioblock-untyi-char ioblock) nil))
1195      (let* ((1st-unit (%ioblock-read-u8-code-unit ioblock)))
1196        (if (eq 1st-unit :eof)
1197          1st-unit
1198          (locally
1199              (declare (type (unsigned-byte 8) 1st-unit))
1200            (if (< 1st-unit
1201                   (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock)))
1202              (%code-char 1st-unit)
1203              (funcall (ioblock-decode-input-function ioblock)
1204                       1st-unit
1205                       #'%ioblock-read-u8-code-unit
1206                       ioblock))))))))
1207
1208(defun %private-ioblock-read-u8-encoded-char (ioblock)
1209  (declare (optimize (speed 3) (safety 0)))
1210  (check-ioblock-owner ioblock)
1211  (%ioblock-read-u8-encoded-char ioblock))
1212
1213(defun %locked-ioblock-read-u8-encoded-char (ioblock)
1214  (declare (optimize (speed 3) (safety 0)))
1215  (with-ioblock-input-lock-grabbed (ioblock)
1216    (%ioblock-read-u8-encoded-char ioblock)))
1217
1218(declaim (inline %ioblock-read-u16-encoded-char))
1219(defun %ioblock-read-u16-encoded-char (ioblock)
1220  (declare (optimize (speed 3) (safety 0)))
1221  (let* ((ch (ioblock-untyi-char ioblock)))
1222    (if ch
1223      (prog1 ch
1224        (setf (ioblock-untyi-char ioblock) nil))
1225      (let* ((1st-unit (%ioblock-read-u16-code-unit ioblock)))
1226        (if (eq 1st-unit :eof)
1227          1st-unit
1228          (locally
1229              (declare (type (unsigned-byte 16) 1st-unit))
1230            (if (< 1st-unit
1231                   (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock)))
1232              (code-char 1st-unit)
1233              (funcall (ioblock-decode-input-function ioblock)
1234                       1st-unit
1235                       #'%ioblock-read-u16-code-unit
1236                       ioblock))))))))
1237
1238(defun %private-ioblock-read-u16-encoded-char (ioblock)
1239  (declare (optimize (speed 3) (safety 0)))
1240  (check-ioblock-owner ioblock)
1241  (%ioblock-read-u16-encoded-char ioblock))
1242
1243(defun %locked-ioblock-read-u16-encoded-char (ioblock)
1244  (declare (optimize (speed 3) (safety 0)))
1245  (with-ioblock-input-lock-grabbed (ioblock)
1246    (%ioblock-read-u16-encoded-char ioblock)))
1247
1248(declaim (inline %ioblock-read-swapped-u16-encoded-char))
1249(defun %ioblock-read-swapped-u16-encoded-char (ioblock)
1250  (declare (optimize (speed 3) (safety 0)))
1251  (let* ((ch (ioblock-untyi-char ioblock)))
1252    (if ch
1253      (prog1 ch
1254        (setf (ioblock-untyi-char ioblock) nil))
1255      (let* ((1st-unit (%ioblock-read-swapped-u16-code-unit ioblock)))
1256        (if (eq 1st-unit :eof)
1257          1st-unit
1258          (locally
1259              (declare (type (unsigned-byte 16) 1st-unit))
1260            (if (< 1st-unit
1261                   (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock)))
1262              (code-char 1st-unit)
1263              (funcall (ioblock-decode-input-function ioblock)
1264                       1st-unit
1265                       #'%ioblock-read-swapped-u16-code-unit
1266                       ioblock))))))))
1267
1268(defun %private-ioblock-read-swapped-u16-encoded-char (ioblock)
1269  (declare (optimize (speed 3) (safety 0)))
1270  (check-ioblock-owner ioblock)
1271  (%ioblock-read-swapped-u16-encoded-char ioblock))
1272
1273(defun %locked-ioblock-read-swapped-u16-encoded-char (ioblock)
1274  (declare (optimize (speed 3) (safety 0)))
1275  (with-ioblock-input-lock-grabbed (ioblock)
1276    (%ioblock-read-swapped-u16-encoded-char ioblock)))
1277
1278(declaim (inline %ioblock-read-u32-encoded-char))
1279(defun %ioblock-read-u32-encoded-char (ioblock)
1280  (declare (optimize (speed 3) (safety 0)))
1281  (let* ((ch (ioblock-untyi-char ioblock)))
1282    (if ch
1283      (prog1 ch
1284        (setf (ioblock-untyi-char ioblock) nil))
1285      (let* ((1st-unit (%ioblock-read-u32-code-unit ioblock)))
1286        (if (eq 1st-unit :eof)
1287          1st-unit
1288          (locally
1289              (declare (type (unsigned-byte 16) 1st-unit))
1290            (if (< 1st-unit
1291                   (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock)))
1292              (code-char 1st-unit)
1293              (funcall (ioblock-decode-input-function ioblock)
1294                       1st-unit
1295                       #'%ioblock-read-u32-code-unit
1296                       ioblock))))))))
1297
1298(defun %private-ioblock-read-u32-encoded-char (ioblock)
1299  (declare (optimize (speed 3) (safety 0)))
1300  (check-ioblock-owner ioblock)
1301  (%ioblock-read-u32-encoded-char ioblock))
1302
1303(defun %locked-ioblock-read-u32-encoded-char (ioblock)
1304  (declare (optimize (speed 3) (safety 0)))
1305  (with-ioblock-input-lock-grabbed (ioblock)
1306    (%ioblock-read-u32-encoded-char ioblock)))
1307
1308(declaim (inline %ioblock-read-swapped-u32-encoded-char))
1309(defun %ioblock-read-swapped-u32-encoded-char (ioblock)
1310  (declare (optimize (speed 3) (safety 0)))
1311  (let* ((ch (ioblock-untyi-char ioblock)))
1312    (if ch
1313      (prog1 ch
1314        (setf (ioblock-untyi-char ioblock) nil))
1315      (let* ((1st-unit (%ioblock-read-swapped-u32-code-unit ioblock)))
1316        (if (eq 1st-unit :eof)
1317          1st-unit
1318          (locally
1319              (declare (type (unsigned-byte 16) 1st-unit))
1320            (if (< 1st-unit
1321                   (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock)))
1322              (code-char 1st-unit)
1323              (funcall (ioblock-decode-input-function ioblock)
1324                       1st-unit
1325                       #'%ioblock-read-swapped-u32-code-unit
1326                       ioblock))))))))
1327
1328(defun %private-ioblock-read-swapped-u32-encoded-char (ioblock)
1329  (declare (optimize (speed 3) (safety 0)))
1330  (check-ioblock-owner ioblock)
1331  (%ioblock-read-swapped-u32-encoded-char ioblock))
1332
1333(defun %locked-ioblock-read-swapped-u32-encoded-char (ioblock)
1334  (declare (optimize (speed 3) (safety 0)))
1335  (with-ioblock-input-lock-grabbed (ioblock)
1336    (%ioblock-read-swapped-u32-encoded-char ioblock)))
1337
1338(declaim (inline %ioblock-tyi-no-hang))
1339(defun %ioblock-tyi-no-hang (ioblock)
1340  (declare (optimize (speed 3) (safety 0)))
1341  (if (ioblock-untyi-char ioblock)
1342    (prog1 (ioblock-untyi-char ioblock)
1343      (setf (ioblock-untyi-char ioblock) nil))
1344    (let* ((buf (ioblock-inbuf ioblock))
1345           (idx (io-buffer-idx buf))
1346           (limit (io-buffer-count buf)))
1347      (declare (fixnum idx limit))
1348      (when (= idx limit)
1349        (unless (%ioblock-advance ioblock nil)
1350          (return-from %ioblock-tyi-no-hang (if (ioblock-eof ioblock) :eof))))
1351      (funcall (ioblock-read-char-when-locked-function ioblock) ioblock))))
1352
1353;;; :iso-8859-1 only.
1354(defun %ioblock-peek-char (ioblock)
1355  (or (ioblock-untyi-char ioblock)
1356      (let* ((buf (ioblock-inbuf ioblock))
1357             (idx (io-buffer-idx buf))
1358             (limit (io-buffer-count buf)))
1359        (declare (fixnum idx limit))
1360        (when (= idx limit)
1361          (unless (%ioblock-advance ioblock t)
1362            (return-from %ioblock-peek-char :eof))
1363          (setq idx (io-buffer-idx buf)
1364                limit (io-buffer-count buf)))
1365        (%code-char (aref (the (simple-array (unsigned-byte 8) (*)) (io-buffer-buffer buf)) idx)))))
1366
1367(defun %encoded-ioblock-peek-char (ioblock)
1368  (or (ioblock-untyi-char ioblock)
1369      (let* ((ch (funcall (ioblock-read-char-when-locked-function ioblock) ioblock)))
1370        (unless (eq ch :eof)
1371          (setf (ioblock-untyi-char ioblock) ch))
1372        ch)))
1373
1374
1375
1376
1377(defun %ioblock-clear-input (ioblock)   
1378    (let* ((buf (ioblock-inbuf ioblock)))
1379      (setf (io-buffer-count buf) 0
1380            (io-buffer-idx buf) 0
1381            (ioblock-untyi-char ioblock) nil)))
1382
1383(defun %ioblock-untyi (ioblock char)
1384  (if (ioblock-untyi-char ioblock)
1385    (error "Two UNREAD-CHARs without intervening READ-CHAR on ~s"
1386           (ioblock-stream ioblock))
1387    (setf (ioblock-untyi-char ioblock) char)))
1388
1389(declaim (inline ioblock-inpos))
1390
1391(defun ioblock-inpos (ioblock)
1392  (io-buffer-idx (ioblock-inbuf ioblock)))
1393
1394(declaim (inline ioblock-outpos))
1395
1396(defun ioblock-outpos (ioblock)
1397  (io-buffer-count (ioblock-outbuf ioblock)))
1398
1399
1400
1401(declaim (inline %ioblock-force-output))
1402
1403(defun %ioblock-force-output (ioblock finish-p)
1404  (funcall (ioblock-force-output-function ioblock)
1405           (ioblock-stream ioblock)
1406           ioblock
1407           (ioblock-outpos ioblock)
1408           finish-p))
1409
1410;;; ivector should be an ivector.  The ioblock should have an
1411;;; element-shift of 0; start-octet and num-octets should of course
1412;;; be sane.  This is mostly to give the fasdumper a quick way to
1413;;; write immediate data.
1414(defun %ioblock-out-ivect (ioblock ivector start-octet num-octets)
1415  (unless (= 0 (the fixnum (ioblock-element-shift ioblock)))
1416    (error "Can't write vector to stream ~s" (ioblock-stream ioblock)))
1417  (let* ((written 0)
1418         (out (ioblock-outbuf ioblock))
1419         (bufsize (io-buffer-size out))
1420         (buffer (io-buffer-buffer out)))
1421    (declare (fixnum written bufsize))
1422    (do* ((pos start-octet (+ pos written))
1423          (left num-octets (- left written)))
1424         ((= left 0) num-octets)
1425      (declare (fixnum pos left))
1426      (setf (ioblock-dirty ioblock) t)
1427      (let* ((index (io-buffer-idx out))
1428             (count (io-buffer-count out))
1429             (avail (- bufsize index)))
1430        (declare (fixnum index avail count))
1431        (cond
1432          ((= (setq written avail) 0)
1433           (%ioblock-force-output ioblock nil))
1434          (t
1435           (if (> written left)
1436             (setq written left))
1437           (%copy-ivector-to-ivector ivector pos buffer index written)
1438           (setf (ioblock-dirty ioblock) t)
1439           (incf index written)
1440           (if (> index count)
1441             (setf (io-buffer-count out) index))
1442           (setf (io-buffer-idx out) index)
1443           (if (= index  bufsize)
1444             (%ioblock-force-output ioblock nil))))))))
1445
1446
1447(defun %ioblock-unencoded-write-simple-string (ioblock string start-char num-chars)
1448  (declare (fixnum start-char num-chars) (simple-string string))
1449  (let* ((written 0)
1450         (col (ioblock-charpos ioblock))
1451         (out (ioblock-outbuf ioblock))
1452         (bufsize (io-buffer-size out))
1453         (buffer (io-buffer-buffer out)))
1454    (declare (fixnum written bufsize col)
1455             (type (simple-array (unsigned-byte 8) (*)) buffer)
1456             (optimize (speed 3) (safety 0)))
1457    (do* ((pos start-char (+ pos written))
1458          (left num-chars (- left written)))
1459         ((= left 0) (setf (ioblock-charpos ioblock) col)  num-chars)
1460      (declare (fixnum pos left))
1461      (setf (ioblock-dirty ioblock) t)
1462      (let* ((index (io-buffer-idx out))
1463             (count (io-buffer-count out))
1464             (avail (- bufsize index)))
1465        (declare (fixnum index avail count))
1466        (cond
1467          ((= (setq written avail) 0)
1468           (%ioblock-force-output ioblock nil))
1469          (t
1470           (if (> written left)
1471             (setq written left))
1472           (do* ((p pos (1+ p))
1473                 (i index (1+ i))
1474                 (j 0 (1+ j)))
1475                ((= j written))
1476             (declare (fixnum p i j))
1477             (let* ((ch (schar string p))
1478                    (code (char-code ch)))
1479               (declare (type (mod #x110000) code))
1480               (if (eql ch #\newline)
1481                 (setq col 0)
1482                 (incf col))
1483               (setf (aref buffer i) (if (>= code 256) (char-code #\Sub) code))))
1484           (setf (ioblock-dirty ioblock) t)
1485           (incf index written)
1486           (if (> index count)
1487             (setf (io-buffer-count out) index))
1488           (setf (io-buffer-idx out) index)
1489           (if (= index  bufsize)
1490             (%ioblock-force-output ioblock nil))))))))
1491
1492
1493
1494(defun %ioblock-eofp (ioblock)
1495  (let* ((buf (ioblock-inbuf ioblock)))
1496   (and (eql (io-buffer-idx buf)
1497             (io-buffer-count buf))
1498         (locally (declare (optimize (speed 3) (safety 0)))
1499           (with-ioblock-input-locked (ioblock)
1500             (funcall (ioblock-eofp-function ioblock)
1501                      (ioblock-stream ioblock)
1502                      ioblock))))))
1503
1504(defun %ioblock-listen (ioblock)
1505  (let* ((buf (ioblock-inbuf ioblock)))
1506    (or (< (the fixnum (io-buffer-idx buf))
1507           (the fixnum (io-buffer-count buf)))
1508        (funcall (ioblock-listen-function ioblock)
1509                 (ioblock-stream ioblock)
1510                 ioblock))))
1511
1512(declaim (inline %ioblock-write-element))
1513
1514(defun %ioblock-write-element (ioblock element)
1515  (declare (optimize (speed 3) (safety 0)))
1516  (let* ((buf (ioblock-outbuf ioblock))
1517         (idx (io-buffer-idx buf))
1518         (count (io-buffer-count buf))
1519         (limit (io-buffer-limit buf)))
1520    (declare (fixnum idx limit count))
1521    (when (= idx limit)
1522      (%ioblock-force-output ioblock nil)
1523      (setq idx 0 count 0))
1524    (setf (aref (io-buffer-buffer buf) idx) element)
1525    (incf idx)
1526    (setf (io-buffer-idx buf) idx)
1527    (when (> idx count)
1528      (setf (io-buffer-count buf) idx))
1529    (setf (ioblock-dirty ioblock) t)
1530    element))
1531
1532(declaim (inline %ioblock-write-u8-element))
1533(defun %ioblock-write-u8-element (ioblock element)
1534  (declare (optimize (speed 3) (safety 0)))
1535  (let* ((buf (ioblock-outbuf ioblock))
1536         (idx (io-buffer-idx buf))
1537         (count (io-buffer-count buf))
1538         (limit (io-buffer-limit buf)))
1539    (declare (fixnum idx limit count))
1540    (when (= idx limit)
1541      (%ioblock-force-output ioblock nil)
1542      (setq idx 0 count 0))
1543    (setf (aref (the (simple-array (unsigned-byte 8) (*)) (io-buffer-buffer buf)) idx) element)
1544    (incf idx)
1545    (setf (io-buffer-idx buf) idx)
1546    (when (> idx count)
1547      (setf (io-buffer-count buf) idx))
1548    (setf (ioblock-dirty ioblock) t)
1549    element))
1550
1551(declaim (inline %ioblock-write-s8-element))
1552(defun %ioblock-write-s8-element (ioblock element)
1553  (declare (optimize (speed 3) (safety 0)))
1554  (let* ((buf (ioblock-outbuf ioblock))
1555         (idx (io-buffer-idx buf))
1556         (count (io-buffer-count buf))
1557         (limit (io-buffer-limit buf)))
1558    (declare (fixnum idx limit count))
1559    (when (= idx limit)
1560      (%ioblock-force-output ioblock nil)
1561      (setq idx 0 count 0))
1562    (setf (aref (the (simple-array (signed-byte 8) (*)) (io-buffer-buffer buf)) idx) element)
1563    (incf idx)
1564    (setf (io-buffer-idx buf) idx)
1565    (when (> idx count)
1566      (setf (io-buffer-count buf) idx))
1567    (setf (ioblock-dirty ioblock) t)
1568    element))
1569
1570(declaim (inline %ioblock-write-u16-element))
1571(defun %ioblock-write-u16-element (ioblock element)
1572  (declare (optimize (speed 3) (safety 0)))
1573  (let* ((buf (ioblock-outbuf ioblock))
1574         (idx (io-buffer-idx buf))
1575         (count (io-buffer-count buf))
1576         (limit (io-buffer-limit buf)))
1577    (declare (fixnum idx limit count))
1578    (when (= idx limit)
1579      (%ioblock-force-output ioblock nil)
1580      (setq idx 0 count 0))
1581    (setf (aref (the (simple-array (unsigned-byte 16) (*)) (io-buffer-buffer buf)) idx) element)
1582    (incf idx)
1583    (setf (io-buffer-idx buf) idx)
1584    (when (> idx count)
1585      (setf (io-buffer-count buf) idx))
1586    (setf (ioblock-dirty ioblock) t)
1587    element))
1588
1589(declaim (inline %ioblock-write-u16-code-unit))
1590(defun %ioblock-write-u16-code-unit (ioblock element)
1591  (declare (optimize (speed 3) (safety 0))
1592           (type (unsigned-byte 16) element))
1593  (let* ((buf (ioblock-outbuf ioblock))
1594         (idx (io-buffer-idx buf))
1595         (count (io-buffer-count buf))
1596         (limit (io-buffer-limit buf))
1597         (vector (io-buffer-buffer buf))
1598         (b0 #+big-endian-target (ldb (byte 8 8) element)
1599             #+little-endian-target (ldb (byte 8 0) element))
1600         (b1 #+big-endian-target (ldb (byte 8 0) element)
1601             #+little-endian-target (ldb (byte 8 8) element)))
1602    (declare (fixnum idx limit count)
1603             (type (simple-array (unsigned-byte 8) (*)) vector)
1604             (type (unsigned-byte 8) b0 b1))
1605   
1606    (when (= idx limit)
1607      (%ioblock-force-output ioblock nil)
1608      (setq idx 0 count 0))
1609    (setf (aref vector idx) b0)
1610    (incf idx)
1611    (when (= idx limit)
1612      (when (> idx count)
1613        (setf (io-buffer-count buf) idx))
1614      (%ioblock-force-output ioblock nil)
1615      (setq idx 0 count 0))
1616    (setf (aref vector idx) b1)
1617    (incf idx)
1618    (setf (io-buffer-idx buf) idx)
1619    (when (> idx count)
1620      (setf (io-buffer-count buf) idx))
1621    (setf (ioblock-dirty ioblock) t)
1622    element))
1623
1624(declaim (inline %ioblock-write-swapped-u16-code-unit))
1625(defun %ioblock-write-swapped-u16-code-unit (ioblock element)
1626  (declare (optimize (speed 3) (safety 0)))
1627(let* ((buf (ioblock-outbuf ioblock))
1628         (idx (io-buffer-idx buf))
1629         (count (io-buffer-count buf))
1630         (limit (io-buffer-limit buf))
1631         (vector (io-buffer-buffer buf))
1632         (b0 #+big-endian-target (ldb (byte 8 8) element)
1633             #+little-endian-target (ldb (byte 8 0) element))
1634         (b1 #+big-endian-target (ldb (byte 8 0) element)
1635             #+little-endian-target (ldb (byte 8 8) element)))
1636    (declare (fixnum idx limit count)
1637             (type (simple-array (unsigned-byte 8) (*)) vector)
1638             (type (unsigned-byte 8) b0 b1))
1639   
1640    (when (= idx limit)
1641      (%ioblock-force-output ioblock nil)
1642      (setq idx 0 count 0))
1643    (setf (aref vector idx) b1)
1644    (incf idx)
1645    (when (= idx limit)
1646      (when (> idx count)
1647        (setf (io-buffer-count buf) idx))
1648      (%ioblock-force-output ioblock nil)
1649      (setq idx 0 count 0))
1650    (setf (aref vector idx) b0)
1651    (incf idx)
1652    (setf (io-buffer-idx buf) idx)
1653    (when (> idx count)
1654      (setf (io-buffer-count buf) idx))
1655    (setf (ioblock-dirty ioblock) t)
1656    element))
1657
1658(declaim (inline %ioblock-write-u32-code-unit))
1659(defun %ioblock-write-u32-code-unit (ioblock element)
1660  (declare (optimize (speed 3) (safety 0))
1661           (type (unsigned-byte 16) element))
1662  (let* ((buf (ioblock-outbuf ioblock))
1663         (idx (io-buffer-idx buf))
1664         (count (io-buffer-count buf))
1665         (limit (io-buffer-limit buf))
1666         (vector (io-buffer-buffer buf))
1667         (b0 #+big-endian-target (ldb (byte 8 24) element)
1668             #+little-endian-target (ldb (byte 8 0) element))
1669         (b1 #+big-endian-target (ldb (byte 8 16) element)
1670             #+little-endian-target (ldb (byte 8 8) element))
1671         (b2 #+big-endian-target (ldb (byte 8 8) element)
1672             #+little-endian-target (ldb (byte 8 16) element))
1673         (b3 #+big-endian-target (ldb (byte 8 0) element)
1674             #+little-endian-target (ldb (byte 8 24) element)))
1675    (declare (fixnum idx limit count)
1676             (type (simple-array (unsigned-byte 8) (*)) vector)
1677             (type (unsigned-byte 8) b0 b1 b2 b3))
1678    (when (= idx limit)
1679      (%ioblock-force-output ioblock nil)
1680      (setq idx 0 count 0))
1681    (setf (aref vector idx) b0)
1682    (incf idx)
1683    (when (= idx limit)
1684      (when (> idx count)
1685        (setf (io-buffer-count buf) idx))
1686      (%ioblock-force-output ioblock nil)
1687      (setq idx 0 count 0))
1688    (setf (aref vector idx) b1)
1689    (incf idx)
1690    (when (= idx limit)
1691      (when (> idx count)
1692        (setf (io-buffer-count buf) idx))
1693      (%ioblock-force-output ioblock nil)
1694      (setq idx 0 count 0))
1695    (setf (aref vector idx) b2)
1696    (incf idx)
1697    (when (= idx limit)
1698      (when (> idx count)
1699        (setf (io-buffer-count buf) idx))
1700      (%ioblock-force-output ioblock nil)
1701      (setq idx 0 count 0))
1702    (setf (aref vector idx) b3)
1703    (incf idx)
1704    (setf (io-buffer-idx buf) idx)
1705    (when (> idx count)
1706      (setf (io-buffer-count buf) idx))
1707    (setf (ioblock-dirty ioblock) t)
1708    element))
1709
1710(declaim (inline %ioblock-write-swapped-u32-code-unit))
1711(defun %ioblock-write-swapped-u32-code-unit (ioblock element)
1712  (declare (optimize (speed 3) (safety 0))
1713           (type (unsigned-byte 16) element))
1714  (let* ((buf (ioblock-outbuf ioblock))
1715         (idx (io-buffer-idx buf))
1716         (count (io-buffer-count buf))
1717         (limit (io-buffer-limit buf))
1718         (vector (io-buffer-buffer buf))
1719         (b0 #+little-endian-target (ldb (byte 8 24) element)
1720             #+big-endian-target (ldb (byte 8 0) element))
1721         (b1 #+little-endian-target (ldb (byte 8 16) element)
1722             #+big-endian-target (ldb (byte 8 8) element))
1723         (b2 #+little-endian-target (ldb (byte 8 8) element)
1724             #+big-endian-target (ldb (byte 8 16) element))
1725         (b3 #+little-endian-target (ldb (byte 8 0) element)
1726             #+big-endian-target (ldb (byte 8 24) element)))
1727    (declare (fixnum idx limit count)
1728             (type (simple-array (unsigned-byte 8) (*)) vector)
1729             (type (unsigned-byte 8) b0 b1 b2 b3))
1730    (when (= idx limit)
1731      (%ioblock-force-output ioblock nil)
1732      (setq idx 0 count 0))
1733    (setf (aref vector idx) b0)
1734    (incf idx)
1735    (when (= idx limit)
1736      (when (> idx count)
1737        (setf (io-buffer-count buf) idx))
1738      (%ioblock-force-output ioblock nil)
1739      (setq idx 0 count 0))
1740    (setf (aref vector idx) b1)
1741    (incf idx)
1742    (when (= idx limit)
1743      (when (> idx count)
1744        (setf (io-buffer-count buf) idx))
1745      (%ioblock-force-output ioblock nil)
1746      (setq idx 0 count 0))
1747    (setf (aref vector idx) b2)
1748    (incf idx)
1749    (when (= idx limit)
1750      (when (> idx count)
1751        (setf (io-buffer-count buf) idx))
1752      (%ioblock-force-output ioblock nil)
1753      (setq idx 0 count 0))
1754    (setf (aref vector idx) b3)
1755    (incf idx)
1756    (setf (io-buffer-idx buf) idx)
1757    (when (> idx count)
1758      (setf (io-buffer-count buf) idx))
1759    (setf (ioblock-dirty ioblock) t)
1760    element))
1761
1762(declaim (inline %ioblock-write-s16-element))
1763(defun %ioblock-write-s16-element (ioblock element)
1764  (declare (optimize (speed 3) (safety 0)))
1765  (let* ((buf (ioblock-outbuf ioblock))
1766         (idx (io-buffer-idx buf))
1767         (count (io-buffer-count buf))
1768         (limit (io-buffer-limit buf)))
1769    (declare (fixnum idx limit count))
1770    (when (= idx limit)
1771      (%ioblock-force-output ioblock nil)
1772      (setq idx 0 count 0))
1773    (setf (aref (the (simple-array (signed-byte 16) (*)) (io-buffer-buffer buf)) idx) element)
1774    (incf idx)
1775    (setf (io-buffer-idx buf) idx)
1776    (when (> idx count)
1777      (setf (io-buffer-count buf) idx))
1778    (setf (ioblock-dirty ioblock) t)
1779    element))
1780
1781(declaim (inline %ioblock-write-u32-element))
1782(defun %ioblock-write-u32-element (ioblock element)
1783  (declare (optimize (speed 3) (safety 0)))
1784  (let* ((buf (ioblock-outbuf ioblock))
1785         (idx (io-buffer-idx buf))
1786         (count (io-buffer-count buf))
1787         (limit (io-buffer-limit buf)))
1788    (declare (fixnum idx limit count))
1789    (when (= idx limit)
1790      (%ioblock-force-output ioblock nil)
1791      (setq idx 0 count 0))
1792    (setf (aref (the (simple-array (unsigned-byte 32) (*)) (io-buffer-buffer buf)) idx) element)
1793    (incf idx)
1794    (setf (io-buffer-idx buf) idx)
1795    (when (> idx count)
1796      (setf (io-buffer-count buf) idx))
1797    (setf (ioblock-dirty ioblock) t)
1798    element))
1799
1800(declaim (inline %ioblock-write-swapped-u32-element))
1801(defun %ioblock-write-swapped-u32-element (ioblock element)
1802  (declare (optimize (speed 3) (safety 0)))
1803  (let* ((buf (ioblock-outbuf ioblock))
1804         (idx (io-buffer-idx buf))
1805         (count (io-buffer-count buf))
1806         (limit (io-buffer-limit buf)))
1807    (declare (fixnum idx limit count))
1808    (when (= idx limit)
1809      (%ioblock-force-output ioblock nil)
1810      (setq idx 0 count 0))
1811    (setf (aref (the (simple-array (unsigned-byte 32) (*)) (io-buffer-buffer buf)) idx)
1812          (%swap-u32 element))
1813    (incf idx)
1814    (setf (io-buffer-idx buf) idx)
1815    (when (> idx count)
1816      (setf (io-buffer-count buf) idx))
1817    (setf (ioblock-dirty ioblock) t)
1818    element))
1819
1820(declaim (inline %ioblock-write-s32-element))
1821(defun %ioblock-write-s32-element (ioblock element)
1822  (declare (optimize (speed 3) (safety 0)))
1823  (let* ((buf (ioblock-outbuf ioblock))
1824         (idx (io-buffer-idx buf))
1825         (count (io-buffer-count buf))
1826         (limit (io-buffer-limit buf)))
1827    (declare (fixnum idx limit count))
1828    (when (= idx limit)
1829      (%ioblock-force-output ioblock nil)
1830      (setq idx 0 count 0))
1831    (setf (aref (the (simple-array (signed-byte 32) (*)) (io-buffer-buffer buf)) idx) element)
1832    (incf idx)
1833    (setf (io-buffer-idx buf) idx)
1834    (when (> idx count)
1835      (setf (io-buffer-count buf) idx))
1836    (setf (ioblock-dirty ioblock) t)
1837    element))
1838
1839#+64-bit-target
1840(progn
1841(declaim (inline %ioblock-write-u64-element))
1842(defun %ioblock-write-u64-element (ioblock element)
1843  (declare (optimize (speed 3) (safety 0)))
1844  (let* ((buf (ioblock-outbuf ioblock))
1845         (idx (io-buffer-idx buf))
1846         (count (io-buffer-count buf))
1847         (limit (io-buffer-limit buf)))
1848    (declare (fixnum idx limit count))
1849    (when (= idx limit)
1850      (%ioblock-force-output ioblock nil)
1851      (setq idx 0 count 0))
1852    (setf (aref (the (simple-array (unsigned-byte 64) (*)) (io-buffer-buffer buf)) idx) element)
1853    (incf idx)
1854    (setf (io-buffer-idx buf) idx)
1855    (when (> idx count)
1856      (setf (io-buffer-count buf) idx))
1857    (setf (ioblock-dirty ioblock) t)
1858    element))
1859
1860(declaim (inline %ioblock-write-s64-element))
1861(defun %ioblock-write-s64-element (ioblock element)
1862  (declare (optimize (speed 3) (safety 0)))
1863  (let* ((buf (ioblock-outbuf ioblock))
1864         (idx (io-buffer-idx buf))
1865         (count (io-buffer-count buf))
1866         (limit (io-buffer-limit buf)))
1867    (declare (fixnum idx limit count))
1868    (when (= idx limit)
1869      (%ioblock-force-output ioblock nil)
1870      (setq idx 0 count 0))
1871    (setf (aref (the (simple-array (signed-byte 64) (*)) (io-buffer-buffer buf)) idx) element)
1872    (incf idx)
1873    (setf (io-buffer-idx buf) idx)
1874    (when (> idx count)
1875      (setf (io-buffer-count buf) idx))
1876    (setf (ioblock-dirty ioblock) t)
1877    element))
1878)
1879
1880(declaim (inline %ioblock-write-char))
1881(defun %ioblock-write-char (ioblock char)
1882  (declare (optimize (speed 3) (safety 0)))
1883  (if (eq char #\linefeed)
1884    (setf (ioblock-charpos ioblock) 0)
1885    (incf (ioblock-charpos ioblock)))
1886  (let* ((code (char-code char)))
1887    (declare (type (mod #x110000) code))
1888    (if (< code 256)
1889      (%ioblock-write-u8-element ioblock code)
1890      (%ioblock-write-u8-element ioblock (char-code #\Sub)))))
1891
1892(defun %private-ioblock-write-char (ioblock char)
1893  (declare (optimize (speed 3) (safety 0)))
1894  (check-ioblock-owner ioblock)
1895  (%ioblock-write-char ioblock char))
1896
1897(defun %locked-ioblock-write-char (ioblock char)
1898  (declare (optimize (speed 3) (safety 0)))
1899  (with-ioblock-output-lock-grabbed (ioblock)
1900    (%ioblock-write-char ioblock char)))
1901
1902(declaim (inline %ioblock-write-u8-encoded-char))
1903(defun %ioblock-write-u8-encoded-char (ioblock char)
1904  (declare (optimize (speed 3) (safety 0)))
1905  (if (eq char #\linefeed)
1906    (setf (ioblock-charpos ioblock) 0)
1907    (incf (ioblock-charpos ioblock)))
1908  (let* ((code (char-code char)))
1909    (declare (type (mod #x110000) code))
1910    (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock)))
1911      (%ioblock-write-u8-element ioblock code)
1912      (funcall (ioblock-encode-output-function ioblock)
1913               char
1914               #'%ioblock-write-u8-element
1915               ioblock))))
1916
1917(defun %private-ioblock-write-u8-encoded-char (ioblock char)
1918  (declare (optimize (speed 3) (safety 0)))
1919  (check-ioblock-owner ioblock)
1920  (%ioblock-write-u8-encoded-char ioblock char))
1921
1922(defun %locked-ioblock-write-u8-encoded-char (ioblock char)
1923  (declare (optimize (speed 3) (safety 0)))
1924  (with-ioblock-output-lock-grabbed (ioblock) 
1925    (%ioblock-write-u8-encoded-char ioblock char)))
1926
1927
1928(defun %ioblock-write-u8-encoded-simple-string (ioblock string start-char num-chars)
1929  (declare (fixnum start-char num-chars)
1930           (simple-base-strng string)
1931           (optimize (speed 3) (safety 0)))
1932  (do* ((i 0 (1+ i))
1933        (col (ioblock-charpos ioblock))
1934        (limit (ioblock-encode-literal-char-code-limit ioblock))
1935        (encode-function (ioblock-encode-output-function ioblock))
1936        (start-char start-char (1+ start-char)))
1937       ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
1938    (declare (fixnum i start-char limit))
1939    (let* ((char (schar string start-char))
1940           (code (char-code char)))
1941      (declare (type (mod #x110000) code))
1942      (if (eq char #\newline)
1943        (setq col 0)
1944        (incf col))
1945      (if (< code limit)
1946               (%ioblock-write-u8-element ioblock code)
1947               (funcall encode-function char #'%ioblock-write-u8-element ioblock)))))
1948
1949
1950(declaim (inline %ioblock-write-u16-encoded-char))
1951(defun %ioblock-write-u16-encoded-char (ioblock char)
1952  (declare (optimize (speed 3) (safety 0)))
1953  (when (ioblock-pending-byte-order-mark ioblock)
1954    (setf (ioblock-pending-byte-order-mark ioblock) nil)
1955    (%ioblock-write-u16-code-unit ioblock byte-order-mark-char-code))
1956  (if (eq char #\linefeed)
1957    (setf (ioblock-charpos ioblock) 0)
1958    (incf (ioblock-charpos ioblock)))
1959  (let* ((code (char-code char)))
1960    (declare (type (mod #x110000) code))
1961    (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock)))
1962      (%ioblock-write-u16-code-unit ioblock code)
1963      (funcall (ioblock-encode-output-function ioblock)
1964               char
1965               #'%ioblock-write-u16-code-unit
1966               ioblock))))
1967
1968(defun %private-ioblock-write-u16-encoded-char (ioblock char)
1969  (declare (optimize (speed 3) (safety 0)))
1970  (check-ioblock-owner ioblock)
1971  (%ioblock-write-u16-encoded-char ioblock char))
1972
1973(defun %locked-ioblock-write-u16-encoded-char (ioblock char)
1974  (declare (optimize (speed 3) (safety 0)))
1975  (with-ioblock-output-lock-grabbed (ioblock)
1976    (%ioblock-write-u16-encoded-char ioblock char)))
1977
1978
1979(defun %ioblock-write-u16-encoded-simple-string (ioblock string start-char num-chars)
1980  (declare (fixnum start-char num-chars)
1981           (simple-base-strng string)
1982           (optimize (speed 3) (safety 0)))
1983  (when (ioblock-pending-byte-order-mark ioblock)
1984    (setf (ioblock-pending-byte-order-mark ioblock) nil)
1985    (%ioblock-write-u16-code-unit ioblock byte-order-mark-char-code))
1986  (do* ((i 0 (1+ i))
1987        (col (ioblock-charpos ioblock))
1988        (limit (ioblock-encode-literal-char-code-limit ioblock))
1989        (encode-function (ioblock-encode-output-function ioblock))
1990        (start-char start-char (1+ start-char)))
1991       ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
1992    (declare (fixnum i start-char limit))
1993    (let* ((char (schar string start-char))
1994           (code (char-code char)))
1995      (declare (type (mod #x110000) code))
1996      (if (eq char #\newline)
1997        (setq col 0)
1998        (incf col))
1999      (if (< code limit)
2000        (%ioblock-write-u16-code-unit ioblock code)
2001        (funcall encode-function char #'%ioblock-write-u16-code-unit ioblock)))))
2002
2003(declaim (inline %ioblock-write-swapped-u16-encoded-char))
2004(defun %ioblock-write-swapped-u16-encoded-char (ioblock char)
2005  (declare (optimize (speed 3) (safety 0)))
2006  (if (eq char #\linefeed)
2007    (setf (ioblock-charpos ioblock) 0)
2008    (incf (ioblock-charpos ioblock)))
2009  (let* ((code (char-code char)))
2010    (declare (type (mod #x110000) code))
2011    (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock)))
2012      (%ioblock-write-swapped-u16-code-unit ioblock code)
2013      (funcall (ioblock-encode-output-function ioblock)
2014               char
2015               #'%ioblock-write-swapped-u16-code-unit
2016               ioblock))))
2017
2018(defun %private-ioblock-write-swapped-u16-encoded-char (ioblock char)
2019  (declare (optimize (speed 3) (safety 0)))
2020  (check-ioblock-owner ioblock)
2021  (%ioblock-write-swapped-u16-encoded-char ioblock char))
2022
2023(defun %locked-ioblock-write-swapped-u16-encoded-char (ioblock char)
2024  (declare (optimize (speed 3) (safety 0)))
2025  (with-ioblock-output-lock-grabbed (ioblock)
2026    (%ioblock-write-swapped-u16-encoded-char ioblock char)))
2027
2028(defun %ioblock-write-swapped-u16-encoded-simple-string (ioblock string start-char num-chars)
2029  (declare (fixnum start-char num-chars)
2030           (simple-base-strng string)
2031           (optimize (speed 3) (safety 0)))
2032  (do* ((i 0 (1+ i))
2033        (col (ioblock-charpos ioblock))
2034        (limit (ioblock-encode-literal-char-code-limit ioblock))
2035        (encode-function (ioblock-encode-output-function ioblock))
2036        (wcf (ioblock-write-char-when-locked-function ioblock))
2037        (start-char start-char (1+ start-char)))
2038       ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
2039    (declare (fixnum i start-char limit))
2040    (let* ((char (schar string start-char))
2041           (code (char-code char)))
2042      (declare (type (mod #x110000) code))
2043      (cond ((eq char #\newline)
2044             (setq col 0)
2045             (funcall wcf ioblock char))
2046            (t
2047             (incf col)
2048             (if (< code limit)
2049               (%ioblock-write-swapped-u16-code-unit ioblock code)
2050               (funcall encode-function char #'%ioblock-write-swapped-u16-code-unit ioblock)))))))
2051
2052
2053(declaim (inline %ioblock-write-u32-encoded-char))
2054(defun %ioblock-write-u32-encoded-char (ioblock char)
2055  (declare (optimize (speed 3) (safety 0)))
2056  (when (ioblock-pending-byte-order-mark ioblock)
2057    (setf (ioblock-pending-byte-order-mark ioblock) nil)
2058    (%ioblock-write-u32-code-unit ioblock byte-order-mark))
2059  (if (eq char #\linefeed)
2060    (setf (ioblock-charpos ioblock) 0)
2061    (incf (ioblock-charpos ioblock)))
2062  (let* ((code (char-code char)))
2063    (declare (type (mod #x110000 code)))
2064    (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock)))
2065      (%ioblock-write-u32-code-unit ioblock code)
2066      (funcall (ioblock-encode-output-function ioblock)
2067               code
2068               #'%ioblock-write-u32-code-unit
2069               ioblock))))
2070
2071(defun %private-ioblock-write-u32-encoded-char (ioblock char)
2072  (declare (optimize (speed 3) (safety 0)))
2073  (check-ioblock-owner ioblock)
2074  (%ioblock-write-u32-encoded-char ioblock char))
2075
2076(defun %locked-ioblock-write-u32-encoded-char (ioblock char)
2077  (declare (optimize (speed 3) (safety 0))) 
2078  (with-ioblock-output-lock-grabbed (ioblock)
2079    (%ioblock-write-u32-encoded-char ioblock char)))
2080
2081(defun %ioblock-write-u32-encoded-simple-string (ioblock string start-char num-chars)
2082  (declare (fixnum start-char num-chars)
2083           (simple-base-strng string)
2084           (optimize (speed 3) (safety 0)))
2085  (when (ioblock-pending-byte-order-mark ioblock)
2086    (setf (ioblock-pending-byte-order-mark ioblock) nil)
2087    (%ioblock-write-u32-code-unit ioblock byte-order-mark-char-code))
2088  (do* ((i 0 (1+ i))
2089        (col (ioblock-charpos ioblock))
2090        (limit (ioblock-encode-literal-char-code-limit ioblock))
2091        (encode-function (ioblock-encode-output-function ioblock))
2092        (start-char start-char (1+ start-char)))
2093       ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
2094    (declare (fixnum i start-char limit))
2095    (let* ((char (schar string start-char))
2096           (code (char-code char)))
2097      (declare (type (mod #x110000) code))
2098      (if (eq char #\newline)
2099        (setq col 0)
2100        (incf col))
2101      (if (< code limit)
2102        (%ioblock-write-u32-code-unit ioblock code)
2103        (funcall encode-function char #'%ioblock-write-u32-code-unit ioblock)))))
2104
2105
2106(declaim (inline %ioblock-write-swapped-u32-encoded-char))
2107(defun %ioblock-write-swapped-u32-encoded-char (ioblock char)
2108  (declare (optimize (speed 3) (safety 0)))
2109  (if (eq char #\linefeed)
2110    (setf (ioblock-charpos ioblock) 0)
2111    (incf (ioblock-charpos ioblock)))
2112  (let* ((code (char-code char)))
2113    (declare (type (mod #x110000 code)))
2114    (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock)))
2115      (%ioblock-write-swapped-u32-code-unit ioblock code)
2116      (funcall (ioblock-encode-output-function ioblock)
2117               code
2118               #'%ioblock-write-swapped-u32-code-unit
2119               ioblock))))
2120
2121(defun %private-ioblock-write-swapped-u32-encoded-char (ioblock char)
2122  (declare (optimize (speed 3) (safety 0)))
2123  (check-ioblock-owner ioblock)
2124  (%ioblock-write-swapped-u32-encoded-char ioblock char))
2125
2126(defun %locked-ioblock-write-swapped-u32-encoded-char (ioblock char)
2127  (declare (optimize (speed 3) (safety 0))) 
2128  (with-ioblock-output-lock-grabbed (ioblock)
2129    (%ioblock-write-swapped-u32-encoded-char ioblock char)))
2130
2131(defun %ioblock-write-swapped-u32-encoded-simple-string (ioblock string start-char num-chars)
2132  (declare (fixnum start-char num-chars)
2133           (simple-base-strng string)
2134           (optimize (speed 3) (safety 0)))
2135  (do* ((i 0 (1+ i))
2136        (col (ioblock-charpos ioblock))
2137        (limit (ioblock-encode-literal-char-code-limit ioblock))
2138        (encode-function (ioblock-encode-output-function ioblock))
2139        (start-char start-char (1+ start-char)))
2140       ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
2141    (declare (fixnum i start-char limit))
2142    (let* ((char (schar string start-char))
2143           (code (char-code char)))
2144      (declare (type (mod #x110000) code))
2145      (if (eq char #\newline)
2146        (setq col 0)
2147        (incf col))
2148      (if (< code limit)
2149        (%ioblock-write-swapped-u32-code-unit ioblock code)
2150        (funcall encode-function char #'%ioblock-write-swapped-u32-code-unit ioblock)))))
2151
2152(declaim (inline %ioblock-write-u8-byte))
2153(defun %ioblock-write-u8-byte (ioblock byte)
2154  (declare (optimize (speed 3) (safety 0)))
2155  (%ioblock-write-u8-element ioblock (require-type byte '(unsigned-byte 8))))
2156
2157(defun %private-ioblock-write-u8-byte (ioblock byte)
2158  (declare (optimize (speed 3) (safety 0)))
2159  (check-ioblock-owner ioblock)
2160  (%ioblock-write-u8-byte ioblock byte))
2161
2162(defun %locked-ioblock-write-u8-byte (ioblock byte)
2163  (declare (optimize (speed 3) (safety 0)))
2164  (with-ioblock-output-lock-grabbed (ioblock)
2165    (%ioblock-write-u8-byte ioblock byte)))
2166
2167(declaim (inline %ioblock-write-s8-byte))
2168(defun %ioblock-write-s8-byte (ioblock byte)
2169  (declare (optimize (speed 3) (safety 0)))
2170  (%ioblock-write-s8-element ioblock (require-type byte '(signed-byte 8))))
2171
2172(defun %private-ioblock-write-s8-byte (ioblock byte)
2173  (declare (optimize (speed 3) (safety 0)))
2174  (check-ioblock-owner ioblock)
2175  (%ioblock-write-s8-byte ioblock byte))
2176
2177(defun %locked-ioblock-write-s8-byte (ioblock byte)
2178  (declare (optimize (speed 3) (safety 0)))
2179  (with-ioblock-output-lock-grabbed (ioblock)
2180    (%ioblock-write-s8-byte ioblock byte)))
2181
2182(declaim (inline %ioblock-write-u16-byte))
2183(defun %ioblock-write-u16-byte (ioblock byte)
2184  (declare (optimize (speed 3) (safety 0)))
2185  (%ioblock-write-u16-element ioblock (require-type byte '(unsigned-byte 16))))
2186
2187(defun %private-ioblock-write-u16-byte (ioblock byte)
2188  (declare (optimize (speed 3) (safety 0)))
2189  (check-ioblock-owner ioblock)
2190  (%ioblock-write-u16-byte ioblock byte))
2191
2192(defun %locked-ioblock-write-u16-byte (ioblock byte)
2193  (declare (optimize (speed 3) (safety 0)))
2194  (with-ioblock-output-lock-grabbed (ioblock)
2195    (%ioblock-write-u16-byte ioblock byte)))
2196
2197(declaim (inline %ioblock-write-s16-byte))
2198(defun %ioblock-write-s16-byte (ioblock byte)
2199  (declare (optimize (speed 3) (safety 0)))
2200  (%ioblock-write-s16-element ioblock (require-type byte '(signed-byte 16))))
2201
2202(defun %private-ioblock-write-s16-byte (ioblock byte)
2203  (declare (optimize (speed 3) (safety 0)))
2204  (check-ioblock-owner ioblock)
2205  (%ioblock-write-s16-byte ioblock byte))
2206
2207(defun %locked-ioblock-write-s16-byte (ioblock byte)
2208  (declare (optimize (speed 3) (safety 0)))
2209  (with-ioblock-output-lock-grabbed (ioblock)
2210    (%ioblock-write-s16-byte ioblock byte)))
2211
2212(declaim (inline %ioblock-write-u32-byte))
2213(defun %ioblock-write-u32-byte (ioblock byte)
2214  (declare (optimize (speed 3) (safety 0)))
2215  (%ioblock-write-u32-element ioblock (require-type byte '(unsigned-byte 32))))
2216
2217(defun %private-ioblock-write-u32-byte (ioblock byte)
2218  (declare (optimize (speed 3) (safety 0)))
2219  (check-ioblock-owner ioblock)
2220  (%ioblock-write-u32-byte ioblock byte))
2221
2222(defun %locked-ioblock-write-u32-byte (ioblock byte)
2223  (declare (optimize (speed 3) (safety 0)))
2224  (with-ioblock-output-lock-grabbed (ioblock)
2225    (%ioblock-write-u32-byte ioblock byte)))
2226
2227(declaim (inline %ioblock-write-s32-byte))
2228(defun %ioblock-write-s32-byte (ioblock byte)
2229  (declare (optimize (speed 3) (safety 0)))
2230  (%ioblock-write-s32-element ioblock (require-type byte '(signed-byte 32))))
2231
2232(defun %private-ioblock-write-s32-byte (ioblock byte)
2233  (declare (optimize (speed 3) (safety 0)))
2234  (check-ioblock-owner ioblock)
2235  (%ioblock-write-s32-byte ioblock byte))
2236
2237(defun %locked-ioblock-write-s32-byte (ioblock byte)
2238  (declare (optimize (speed 3) (safety 0)))
2239  (with-ioblock-output-lock-grabbed (ioblock)
2240    (%ioblock-write-s32-byte ioblock byte)))
2241
2242#+64-bit-target
2243(progn
2244(declaim (inline %ioblock-write-u64-byte))
2245(defun %ioblock-write-u64-byte (ioblock byte)
2246  (declare (optimize (speed 3) (safety 0)))
2247  (%ioblock-write-u64-element ioblock (require-type byte '(unsigned-byte 64))))
2248
2249(defun %private-ioblock-write-u64-byte (ioblock byte)
2250  (declare (optimize (speed 3) (safety 0)))
2251  (check-ioblock-owner ioblock)
2252  (%ioblock-write-u64-byte ioblock byte))
2253
2254(defun %locked-ioblock-write-u64-byte (ioblock byte)
2255  (declare (optimize (speed 3) (safety 0)))
2256  (with-ioblock-output-lock-grabbed (ioblock)
2257    (%ioblock-write-u64-byte ioblock byte)))
2258
2259(declaim (inline %ioblock-write-s64-byte))
2260(defun %ioblock-write-s64-byte (ioblock byte)
2261  (declare (optimize (speed 3) (safety 0)))
2262  (%ioblock-write-s64-element ioblock (require-type byte '(signed-byte 64))))
2263
2264(defun %private-ioblock-write-s64-byte (ioblock byte)
2265  (declare (optimize (speed 3) (safety 0)))
2266  (check-ioblock-owner ioblock)
2267  (%ioblock-write-s64-byte ioblock byte))
2268
2269(defun %locked-ioblock-write-s64-byte (ioblock byte)
2270  (declare (optimize (speed 3) (safety 0)))
2271  (with-ioblock-output-lock-grabbed (ioblock)
2272    (%ioblock-write-s64-byte ioblock byte)))
2273)                                       ;#+64-bit-target
2274
2275(defun %ioblock-clear-output (ioblock)
2276  (let* ((buf (ioblock-outbuf ioblock)))                     
2277    (setf (io-buffer-count buf) 0
2278            (io-buffer-idx buf) 0)))
2279
2280(defun %ioblock-unencoded-read-line (ioblock)
2281  (let* ((inbuf (ioblock-inbuf ioblock)))
2282    (let* ((string "")
2283           (len 0)
2284           (eof nil)
2285           (buf (io-buffer-buffer inbuf))
2286           (newline (char-code #\newline)))
2287      (let* ((ch (ioblock-untyi-char ioblock)))
2288        (when ch
2289          (setf (ioblock-untyi-char ioblock) nil)
2290          (if (eql ch #\newline)
2291            (return-from %ioblock-unencoded-read-line 
2292              (values string nil))
2293            (progn
2294              (setq string (make-string 1)
2295                    len 1)
2296              (setf (schar string 0) ch)))))
2297      (loop
2298        (let* ((more 0)
2299               (idx (io-buffer-idx inbuf))
2300               (count (io-buffer-count inbuf)))
2301          (declare (fixnum idx count more))
2302          (if (= idx count)
2303            (if eof
2304              (return (values string t))
2305              (progn
2306                (setq eof t)
2307                (%ioblock-advance ioblock t)))
2308            (progn
2309              (setq eof nil)
2310              (let* ((pos (position newline buf :start idx :end count)))
2311                (when pos
2312                  (locally (declare (fixnum pos))
2313                    (setf (io-buffer-idx inbuf) (the fixnum (1+ pos)))
2314                    (setq more (- pos idx))
2315                    (unless (zerop more)
2316                      (setq string
2317                            (%extend-vector
2318                             0 string (the fixnum (+ len more)))))
2319                    (%copy-u8-to-string
2320                     buf idx string len more)
2321                    (return (values string nil))))
2322                ;; No #\newline in the buffer.  Read everything that's
2323                ;; there into the string, and fill the buffer again.
2324                (setf (io-buffer-idx inbuf) count)
2325                (setq more (- count idx)
2326                      string (%extend-vector
2327                              0 string (the fixnum (+ len more))))
2328                (%copy-u8-to-string
2329                 buf idx string len more)
2330                (incf len more)))))))))
2331
2332;;; There are lots of ways of doing better here, but in the most general
2333;;; case we can't tell (a) what a newline looks like in the buffer or (b)
2334;;; whether there's a 1:1 mapping between code units and characters.
2335(defun %ioblock-encoded-read-line (ioblock)
2336  (let* ((str (make-array 20 :element-type 'base-char
2337                          :adjustable t :fill-pointer 0))
2338         (rcf (ioblock-read-char-when-locked-function ioblock))
2339         (eof nil))
2340    (do* ((ch (funcall rcf ioblock) (funcall rcf ioblock)))
2341         ((or (eq ch #\newline) (setq eof (eq ch :eof)))
2342          (values (ensure-simple-string str) eof))
2343      (vector-push-extend ch str))))
2344         
2345(defun %ioblock-unencoded-character-read-vector (ioblock vector start end)
2346  (do* ((i start)
2347        (in (ioblock-inbuf ioblock))
2348        (inbuf (io-buffer-buffer in))
2349        (need (- end start)))
2350       ((= i end) end)
2351    (declare (fixnum i need))
2352    (let* ((ch (%ioblock-tyi ioblock)))
2353      (if (eq ch :eof)
2354        (return i))
2355      (setf (schar vector i) ch)
2356      (incf i)
2357      (decf need)
2358      (let* ((idx (io-buffer-idx in))
2359             (count (io-buffer-count in))
2360             (avail (- count idx)))
2361        (declare (fixnum idx count avail))
2362        (unless (zerop avail)
2363          (if (> avail need)
2364            (setq avail need))
2365          (%copy-u8-to-string inbuf idx vector i avail)
2366          (setf (io-buffer-idx in) (+ idx avail))
2367          (incf i avail)
2368          (decf need avail))))))
2369
2370;;; Also used when newline translation complicates things.
2371(defun %ioblock-encoded-character-read-vector (ioblock vector start end)
2372  (declare (fixnum start end))
2373  (do* ((i start (1+ i))
2374        (rcf (ioblock-read-char-when-locked-function ioblock)))
2375       ((= i end) end)
2376    (declare (fixnum i need))
2377    (let* ((ch (funcall rcf ioblock)))
2378      (if (eq ch :eof)
2379        (return i))
2380      (setf (schar vector i) ch))))
2381
2382
2383(defun %ioblock-binary-read-vector (ioblock vector start end)
2384  (declare (fixnum start end))
2385  (let* ((in (ioblock-inbuf ioblock))
2386         (inbuf (io-buffer-buffer in))
2387         (rbf (ioblock-read-byte-when-locked-function ioblock)))
2388    (setf (ioblock-untyi-char ioblock) nil)
2389    (if (not (= (the fixnum (typecode inbuf))
2390                (the fixnum (typecode vector))))
2391      (do* ((i start (1+ i)))
2392           ((= i end) i)
2393        (declare (fixnum i))
2394        (let* ((b (funcall rbf ioblock)))
2395          (if (eq b :eof)
2396            (return i)
2397            (setf (uvref vector i) b))))
2398      (do* ((i start)
2399            (need (- end start)))
2400           ((= i end) end)
2401        (declare (fixnum i need))
2402        (let* ((b (funcall rbf ioblock)))
2403          (if (eq b :eof)
2404            (return i))
2405          (setf (uvref vector i) b)
2406          (incf i)
2407          (decf need)
2408          (let* ((idx (io-buffer-idx in))
2409                 (count (io-buffer-count in))
2410                 (avail (- count idx)))
2411            (declare (fixnum idx count avail))
2412            (unless (zerop avail)
2413              (if (> avail need)
2414                (setq avail need))
2415              (%copy-ivector-to-ivector
2416               inbuf
2417               (ioblock-elements-to-octets ioblock idx)
2418               vector
2419               (ioblock-elements-to-octets ioblock i)
2420               (ioblock-elements-to-octets ioblock avail))
2421              (setf (io-buffer-idx in) (+ idx avail))
2422              (incf i avail)
2423              (decf need avail))))))))
2424
2425;;; About the same, only less fussy about ivector's element-type.
2426;;; (All fussiness is about the stream's element-type ...).
2427;;; Whatever the element-type is, elements must be 1 octet in size.
2428(defun %ioblock-character-in-ivect (ioblock vector start nb)
2429  (declare (type (simple-array (unsigned-byte 8) (*)) vector)
2430           (fixnum start nb)
2431           (optimize (speed 3) (safety 0)))
2432  (unless (= 0 (the fixnum (ioblock-element-shift ioblock)))
2433    (error "Can't read vector from stream ~s" (ioblock-stream ioblock)))
2434  (do* ((i start)
2435        (in (ioblock-inbuf ioblock))
2436        (inbuf (io-buffer-buffer in))
2437        (need nb)
2438        (end (+ start nb)))
2439       ((= i end) end)
2440    (declare (fixnum i end need))
2441    (let* ((ch (%ioblock-tyi ioblock)))
2442      (if (eq ch :eof)
2443        (return (- i start)))
2444      (setf (aref vector i) (char-code ch))
2445      (incf i)
2446      (decf need)
2447      (let* ((idx (io-buffer-idx in))
2448             (count (io-buffer-count in))
2449             (avail (- count idx)))
2450        (declare (fixnum idx count avail))
2451        (unless (zerop avail)
2452          (if (> avail need)
2453            (setq avail need))
2454          (%copy-u8-to-string inbuf idx vector i avail)
2455          (setf (io-buffer-idx in) (+ idx avail))
2456          (incf i avail)
2457          (decf need avail))))))
2458
2459(defun %ioblock-binary-in-ivect (ioblock vector start nb)
2460  (declare (type (simple-array (unsigned-byte 8) (*)) vector)
2461           (fixnum start nb)
2462           (optimize (speed 3) (safety 0)))
2463  (unless (= 0 (the fixnum (ioblock-element-shift ioblock)))
2464    (error "Can't read vector from stream ~s" (ioblock-stream ioblock)))
2465  (setf (ioblock-untyi-char ioblock) nil)
2466  (do* ((i start)
2467        (rbf (ioblock-read-byte-when-locked-function ioblock))
2468        (in (ioblock-inbuf ioblock))
2469        (inbuf (io-buffer-buffer in))
2470        (need nb)
2471        (end (+ start nb)))
2472       ((= i end) nb)
2473    (declare (fixnum i end need))
2474    (let* ((b (funcall rbf ioblock)))
2475      (if (eq b :eof)
2476        (return (- i start)))
2477      (setf (uvref vector i) b)
2478      (incf i)
2479      (decf need)
2480      (let* ((idx (io-buffer-idx in))
2481             (count (io-buffer-count in))
2482             (avail (- count idx)))
2483        (declare (fixnum idx count avail))
2484        (unless (zerop avail)
2485          (if (> avail need)
2486            (setq avail need))
2487          (%copy-ivector-to-ivector inbuf idx vector i avail)
2488          (setf (io-buffer-idx in) (+ idx avail))
2489          (incf i avail)
2490          (decf need avail))))))
2491
2492;;; Thread must own ioblock lock(s).
2493(defun %%ioblock-close (ioblock)
2494  (when (ioblock-device ioblock)
2495    (let* ((stream (ioblock-stream ioblock)))
2496      (funcall (ioblock-close-function ioblock) stream ioblock)
2497      (setf (ioblock-device ioblock) nil)
2498      (setf (stream-ioblock stream) nil)
2499      (let* ((in-iobuf (ioblock-inbuf ioblock))
2500             (out-iobuf (ioblock-outbuf ioblock))
2501             (in-buffer (if in-iobuf (io-buffer-buffer in-iobuf)))
2502             (in-bufptr (if in-iobuf (io-buffer-bufptr in-iobuf)))
2503             (out-buffer (if out-iobuf (io-buffer-buffer out-iobuf)))
2504             (out-bufptr (if out-iobuf (io-buffer-bufptr out-iobuf))))
2505        (if (and in-buffer in-bufptr)
2506          (%dispose-heap-ivector in-buffer))
2507        (unless (eq in-buffer out-buffer)
2508          (if (and out-buffer out-bufptr)
2509            (%dispose-heap-ivector out-buffer)))
2510        (when in-iobuf
2511          (setf (io-buffer-buffer in-iobuf) nil
2512                (io-buffer-bufptr in-iobuf) nil
2513                (ioblock-inbuf ioblock) nil))
2514        (when out-iobuf
2515          (setf (io-buffer-buffer out-iobuf) nil
2516                (io-buffer-bufptr out-iobuf) nil
2517                (ioblock-outbuf ioblock) nil))
2518        t))))
2519
2520(defun %ioblock-close (ioblock)
2521  (let* ((in-lock (ioblock-inbuf-lock ioblock))
2522         (out-lock (ioblock-outbuf-lock ioblock)))
2523    (if in-lock
2524      (with-lock-grabbed (in-lock)
2525        (if (and out-lock (not (eq out-lock in-lock)))
2526          (with-lock-grabbed (out-lock)
2527            (%%ioblock-close ioblock))
2528          (%%ioblock-close ioblock)))
2529      (if out-lock
2530        (with-lock-grabbed (out-lock)
2531          (%%ioblock-close ioblock))
2532        (progn
2533          (check-ioblock-owner ioblock)
2534          (%%ioblock-close ioblock))))))
2535
2536
2537;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2538
2539;;; Character-at-a-time line-termination-translation functions.
2540;;; It's not always possible to just blast through the buffer, blindly
2541;;; replacing #xd with #xa (for example), and it's not always desirable
2542;;; to do that (if we support changing encoding on open streams.)
2543;;; This is done at a fairly high level; some cases could be done at
2544;;; a lower level, and some cases are hard even at that lower level.
2545;;; This approach doesn't slow down the simple case (when no line-termination
2546;;; translation is used), and hopefully isn't -that- bad.
2547
2548(declaim (inline %ioblock-read-char-translating-cr-to-newline))
2549(defun %ioblock-read-char-translating-cr-to-newline (ioblock)
2550  (let* ((ch (funcall
2551              (ioblock-read-char-without-translation-when-locked-function
2552               ioblock)
2553              ioblock)))
2554    (if (eql ch #\Return)
2555      #\Newline
2556      ch)))
2557
2558(defun %private-ioblock-read-char-translating-cr-to-newline (ioblock)
2559  (check-ioblock-owner ioblock)
2560  (%ioblock-read-char-translating-cr-to-newline ioblock))
2561
2562(defun %locked-ioblock-read-char-translating-cr-to-newline (ioblock)
2563  (with-ioblock-input-lock-grabbed (ioblock)
2564    (%ioblock-read-char-translating-cr-to-newline ioblock)))
2565
2566(declaim (inline %ioblock-read-char-translating-crlf-to-newline))
2567(defun %ioblock-read-char-translating-crlf-to-newline (ioblock)
2568  (let* ((ch (funcall
2569              (ioblock-read-char-without-translation-when-locked-function
2570               ioblock)
2571              ioblock)))
2572    (if (eql ch #\Return)
2573      (let* ((next (funcall
2574                    (ioblock-read-char-without-translation-when-locked-function
2575                     ioblock)
2576                    ioblock)))
2577        (if (eql next #\Linefeed)
2578          next
2579          (progn
2580            (unless (eq next :eof)
2581              (setf (ioblock-untyi-char ioblock) next))
2582            ch)))
2583      ch)))
2584   
2585(defun %private-ioblock-read-char-translating-crlf-to-newline (ioblock)
2586  (check-ioblock-owner ioblock)
2587  (%ioblock-read-char-translating-crlf-to-newline ioblock))
2588
2589(defun %locked-ioblock-read-char-translating-crlf-to-newline (ioblock)
2590  (with-ioblock-input-lock-grabbed (ioblock)
2591    (%ioblock-read-char-translating-crlf-to-newline ioblock)))
2592
2593(declaim (inline %ioblock-read-char-translating-line-separator-to-newline))
2594(defun %ioblock-read-char-translating-line-separator-to-newline (ioblock)
2595  (let* ((ch (funcall
2596              (ioblock-read-char-without-translation-when-locked-function
2597               ioblock)
2598              ioblock)))
2599    (if (eql ch #\Line_Separator)
2600      #\Newline
2601      ch)))
2602
2603(defun %private-ioblock-read-char-translating-line-separator-to-newline (ioblock)
2604  (check-ioblock-owner ioblock)
2605  (%ioblock-read-char-translating-line-separator-to-newline ioblock))
2606
2607(defun %locked-ioblock-read-char-translating-line-separator-to-newline (ioblock)
2608  (with-ioblock-input-lock-grabbed (ioblock)
2609    (%ioblock-read-char-translating-line-separator-to-newline ioblock)))
2610
2611(declaim (inline %ioblock-write-char-translating-newline-to-cr))
2612(defun %ioblock-write-char-translating-newline-to-cr (ioblock char)
2613  (funcall (ioblock-write-char-without-translation-when-locked-function
2614            ioblock)
2615           ioblock
2616           (if (eql char #\Newline) #\Return char)))
2617
2618(defun %private-ioblock-write-char-translating-newline-to-cr (ioblock char)
2619  (check-ioblock-owner ioblock)
2620  (%ioblock-write-char-translating-newline-to-cr ioblock char))
2621
2622(defun %locked-ioblock-write-char-translating-newline-to-cr (ioblock char)
2623  (with-ioblock-input-lock-grabbed (ioblock)
2624    (%ioblock-write-char-translating-newline-to-cr ioblock char)))
2625
2626(declaim (inline %ioblock-write-char-translating-newline-to-crlf))
2627(defun %ioblock-write-char-translating-newline-to-crlf (ioblock char)
2628  (when (eql char #\Newline)
2629    (funcall (ioblock-write-char-without-translation-when-locked-function
2630              ioblock)
2631             ioblock
2632             #\Return))   
2633  (funcall (ioblock-write-char-without-translation-when-locked-function
2634            ioblock)
2635           ioblock
2636           char))
2637
2638(defun %private-ioblock-write-char-translating-newline-to-crlf (ioblock char)
2639  (check-ioblock-owner ioblock)
2640  (%ioblock-write-char-translating-newline-to-crlf ioblock char))
2641
2642(defun %locked-ioblock-write-char-translating-newline-to-crlf (ioblock char)
2643  (with-ioblock-input-lock-grabbed (ioblock)
2644    (%ioblock-write-char-translating-newline-to-crlf ioblock char)))
2645
2646(declaim (inline %ioblock-write-char-translating-newline-to-line-separator))
2647(defun %ioblock-write-char-translating-newline-to-line-separator (ioblock char)
2648  (funcall (ioblock-write-char-without-translation-when-locked-function
2649            ioblock)
2650           ioblock
2651           (if (eql char #\Newline) #\Line_Separator char)))
2652
2653(defun %private-ioblock-write-char-translating-newline-to-line-separator (ioblock char)
2654  (check-ioblock-owner ioblock)
2655  (%ioblock-write-char-translating-newline-to-line-separator ioblock char))
2656
2657(defun %locked-ioblock-write-char-translating-newline-to-line-separator (ioblock char)
2658  (with-ioblock-input-lock-grabbed (ioblock)
2659    (%ioblock-write-char-translating-newline-to-line-separator ioblock char)))
2660
2661;;; If we do newline translation, we probably can't be too clever about reading/writing
2662;;; strings.
2663(defun %ioblock-write-simple-string-with-newline-translation (ioblock string start-pos num-chars)
2664  (declare (fixnum start-char num-chars) (simple-string string))
2665  (let* ((col (ioblock-charpos ioblock))
2666         (wcf (ioblock-write-char-when-locked-function ioblock)))
2667    (declare (fixnum col))
2668    (do* ((i start-pos (1+ i))
2669          (n 0 (1+ n)))
2670         ((= n num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
2671      (let* ((char (schar string i)))
2672        (if (eql char #\Newline)
2673          (setq col 0)
2674          (incf col))
2675        (funcall wcf ioblock char)))))
2676
2677
2678;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2679
2680(defun setup-ioblock-input (ioblock character-p element-type sharing encoding line-termination)
2681  (setf (ioblock-sharing ioblock) sharing)
2682  (when character-p
2683    (setf (ioblock-unread-char-function ioblock) '%ioblock-untyi)
2684    (setf (ioblock-decode-literal-code-unit-limit ioblock)
2685          (if encoding
2686            (character-encoding-decode-literal-code-unit-limit encoding)
2687            256))   
2688    (if encoding
2689      (let* ((unit-size (character-encoding-code-unit-size encoding)))
2690        (setf (ioblock-peek-char-function ioblock) '%encoded-ioblock-peek-char)
2691        (setf (ioblock-read-line-function ioblock)
2692              '%ioblock-encoded-read-line)
2693        (setf (ioblock-character-read-vector-function ioblock)
2694              '%ioblock-encoded-character-read-vector)       
2695        (setf (ioblock-decode-input-function ioblock)
2696              (character-encoding-stream-decode-function encoding))
2697        (setf (ioblock-read-char-function ioblock)
2698              (ecase unit-size
2699                (8
2700                 (setf (ioblock-read-char-when-locked-function ioblock)
2701                       '%ioblock-read-u8-encoded-char)
2702                 (case sharing
2703                   (:private '%private-ioblock-read-u8-encoded-char)
2704                   (:lock '%locked-ioblock-read-u8-encoded-char)
2705                   (t '%ioblock-read-u8-encoded-char)))
2706                (16
2707                 (if (character-encoding-native-endianness encoding)
2708                   (progn
2709                    (setf (ioblock-read-char-when-locked-function ioblock)
2710                          '%ioblock-read-u16-encoded-char)
2711                    (case sharing
2712                      (:private '%private-ioblock-read-u16-encoded-char)
2713                      (:lock '%locked-ioblock-read-u16-encoded-char)
2714                      (t '%ioblock-read-u16-encoded-char)))
2715                   (progn
2716                     (setf (ioblock-read-char-when-locked-function ioblock)
2717                           '%ioblock-read-swapped-u16-encoded-char)
2718                    (case sharing
2719                      (:private '%private-ioblock-read-swapped-u16-encoded-char)
2720                      (:lock '%locked-ioblock-read-swapped-u16-encoded-char)
2721                      (t '%ioblock-read-swapped-u16-encoded-char)))))
2722                (32
2723                 (if (character-encoding-native-endianness encoding)
2724                   (progn
2725                    (setf (ioblock-read-char-when-locked-function ioblock)
2726                          #'%ioblock-read-u32-encoded-char)
2727                    (case sharing
2728                      (:private #'%private-ioblock-read-u32-encoded-char)
2729                      (:lock #'%locked-ioblock-read-u32-encoded-char)
2730                      (t #'%ioblock-read-u32-encoded-char)))
2731                   (progn
2732                     (setf (ioblock-read-char-when-locked-function ioblock)
2733                           #'%ioblock-read-swapped-u32-encoded-char)
2734                    (case sharing
2735                      (:private '#'%private-ioblock-read-swapped-u16-encoded-char)
2736                      (:lock #'%locked-ioblock-read-swapped-u32-encoded-char)
2737                      (t #'%ioblock-read-swapped-u32-encoded-char))))))))
2738      (progn
2739        (setf (ioblock-peek-char-function ioblock) '%ioblock-peek-char)
2740        (setf (ioblock-read-char-function ioblock)
2741              (case sharing
2742                (:private '%private-ioblock-tyi)
2743                (:lock '%locked-ioblock-tyi)
2744                (t '%ioblock-tyi)))
2745        (setf (ioblock-read-char-when-locked-function ioblock)
2746              '%ioblock-tyi)
2747        (setf (ioblock-character-read-vector-function ioblock)
2748              '%ioblock-unencoded-character-read-vector)
2749        (setf (ioblock-read-line-function ioblock)
2750              '%ioblock-unencoded-read-line)))
2751    (when line-termination
2752      (install-ioblock-input-line-termination ioblock line-termination))
2753    )
2754
2755  (unless (or (eq element-type 'character)
2756              (subtypep element-type 'character))
2757    (let* ((subtag (element-type-subtype element-type)))
2758      (declare (type (unsigned-byte 8) subtag))
2759      (setf (ioblock-read-byte-function ioblock)
2760            (cond ((= subtag target::subtag-u8-vector)
2761                   (if character-p
2762                     ;; The bivalent case, at least for now
2763                     (progn
2764                       (setf (ioblock-read-byte-when-locked-function ioblock)
2765                             '%bivalent-ioblock-read-u8-byte)
2766                       (case sharing
2767                         (:private '%bivalent-private-ioblock-read-u8-byte)
2768                         (:lock '%bivalent-locked-ioblock-read-u8-byte)
2769                         (t '%bivalent-ioblock-read-u8-byte)))
2770                     (progn
2771                       (setf (ioblock-read-byte-when-locked-function ioblock)
2772                             '%ioblock-read-u8-byte)
2773                       (case sharing
2774                         (:private '%private-ioblock-read-u8-byte)
2775                         (:lock '%locked-ioblock-read-u8-byte)
2776                         (t '%ioblock-read-u8-byte)))))
2777                  ((= subtag target::subtag-s8-vector)
2778                   (setf (ioblock-read-byte-when-locked-function ioblock)
2779                         '%ioblock-read-s8-byte) 
2780                   (case sharing
2781                     (:private '%private-ioblock-read-s8-byte)
2782                     (:lock '%locked-ioblock-read-s8-byte)
2783                     (t '%ioblock-read-s8-byte)))
2784                  ((= subtag target::subtag-u16-vector)
2785                   (setf (ioblock-read-byte-when-locked-function ioblock)
2786                         '%ioblock-read-u16-byte)
2787                   (case sharing
2788                     (:private '%private-ioblock-read-u16-byte)
2789                     (:lock '%locked-ioblock-read-u16-byte)
2790                     (t '%ioblock-read-u16-byte)))
2791                  ((= subtag target::subtag-s16-vector)
2792                   (setf (ioblock-read-byte-when-locked-function ioblock)
2793                         '%ioblock-read-s16-byte)
2794                   (case sharing
2795                     (:private '%private-ioblock-read-s16-byte)
2796                     (:lock '%locked-ioblock-read-s16-byte)
2797                     (t '%ioblock-read-s16-byte)))
2798                  ((= subtag target::subtag-u32-vector)
2799                   (setf (ioblock-read-byte-when-locked-function ioblock)
2800                         '%ioblock-read-u32-byte)
2801                   (case sharing
2802                     (:private '%private-ioblock-read-u32-byte)
2803                     (:lock '%locked-ioblock-read-u32-byte)
2804                     (t '%ioblock-read-u32-byte)))
2805                  ((= subtag target::subtag-s32-vector)
2806                   (setf (ioblock-read-byte-when-locked-function ioblock)
2807                         '%ioblock-read-s32-byte)                   
2808                   (case sharing
2809                     (:private '%private-ioblock-read-s32-byte)
2810                     (:lock '%locked-ioblock-read-s32-byte)
2811                     (t '%ioblock-read-s32-byte)))
2812                  #+64-bit-target
2813                  ((= subtag target::subtag-u64-vector)
2814                   (setf (ioblock-read-byte-when-locked-function ioblock)
2815                         '%ioblock-read-u64-byte)                   
2816                   (case sharing
2817                     (:private '%private-ioblock-read-u64-byte)
2818                     (:lock '%locked-ioblock-read-u64-byte)
2819                     (t '%ioblock-read-u64-byte)))
2820                  #+64-bit-target
2821                  ((= subtag target::subtag-s64-vector)
2822                   (setf (ioblock-read-byte-when-locked-function ioblock)
2823                         '%ioblock-read-s64-byte)
2824                   (case sharing
2825                     (:private '%private-ioblock-read-s64-byte)
2826                     (:lock '%locked-ioblock-read-s64-byte)
2827                     (t '%ioblock-read-s64-byte)))
2828                  ;; Not sure what this means, currently.
2829                  (t
2830                   (setf (ioblock-read-byte-when-locked-function ioblock)
2831                         '%general-ioblock-read-byte)
2832                   '%general-ioblock-read-byte))))))
2833
2834(defun install-ioblock-input-line-termination (ioblock line-termination)
2835  (when line-termination
2836    (let* ((sharing (ioblock-sharing ioblock)))
2837      (setf (ioblock-read-char-without-translation-when-locked-function ioblock)
2838            (ioblock-read-char-when-locked-function ioblock)
2839            (ioblock-character-read-vector-function ioblock)
2840            '%ioblock-encoded-character-read-vector
2841            (ioblock-read-line-function ioblock) '%ioblock-encoded-read-line)
2842      (ecase line-termination
2843        (:cr (setf (ioblock-read-char-when-locked-function ioblock)
2844                   '%ioblock-read-char-translating-cr-to-newline
2845                   (ioblock-read-char-function ioblock)
2846                   (case sharing
2847                     (:private
2848                      '%private-ioblock-read-char-translating-cr-to-newline)
2849                     (:lock
2850                      '%locked-ioblock-read-char-translating-cr-to-newline)
2851                     (t '%ioblock-read-char-translating-cr-to-newline))))
2852        (:crlf (setf (ioblock-read-char-when-locked-function ioblock)
2853                     '%ioblock-read-char-translating-crlf-to-newline
2854                     (ioblock-read-char-function ioblock)
2855                     (case sharing
2856                       (:private
2857                        '%private-ioblock-read-char-translating-crlf-to-newline)
2858                       (:lock
2859                        '%locked-ioblock-read-char-translating-crlf-to-newline)
2860                       (t '%ioblock-read-char-translating-crlf-to-newline))))
2861        (:unicode (setf (ioblock-read-char-when-locked-function ioblock)
2862                        '%ioblock-read-char-translating-line-separator-to-newline
2863                        (ioblock-read-char-function ioblock)
2864                        (case sharing
2865                          (:private
2866                           '%private-ioblock-read-char-translating-line-separator-to-newline)
2867                          (:lock
2868                           '%locked-ioblock-read-char-translating-line-separator-to-newline)
2869                          (t '%ioblock-read-char-translating-line-separator-to-newline))))))))
2870 
2871(defun setup-ioblock-output (ioblock character-p element-type sharing encoding line-termination)
2872  (or (ioblock-sharing ioblock)
2873      (setf (ioblock-sharing ioblock) sharing))
2874  (when character-p
2875    (setf (ioblock-encode-literal-char-code-limit ioblock)
2876          (if encoding
2877            (character-encoding-encode-literal-char-code-limit encoding)
2878            256))   
2879    (if encoding
2880      (let* ((unit-size (character-encoding-code-unit-size encoding)))
2881        (setf (ioblock-encode-output-function ioblock)
2882              (character-encoding-stream-encode-function encoding))
2883        (setf (ioblock-write-char-function ioblock)
2884              (ecase unit-size
2885                (8
2886                 (setf (ioblock-write-char-when-locked-function ioblock)
2887                       '%ioblock-write-u8-encoded-char) 
2888                 (case sharing
2889                   (:private '%private-ioblock-write-u8-encoded-char)
2890                   (:lock '%locked-ioblock-write-u8-encoded-char)
2891                   (t '%ioblock-write-u8-encoded-char)))
2892                (16
2893                 (if (character-encoding-native-endianness encoding)
2894                   (progn
2895                     (setf (ioblock-write-char-when-locked-function ioblock)
2896                           '%ioblock-write-u16-encoded-char) 
2897                     (case sharing
2898                       (:private '%private-ioblock-write-u16-encoded-char)
2899                       (:lock '%locked-ioblock-write-u16-encoded-char)
2900                       (t '%ioblock-write-u16-encoded-char)))
2901                   (progn
2902                     (setf (ioblock-write-char-when-locked-function ioblock)
2903                           '%ioblock-write-swapped-u16-encoded-char)
2904                     (case sharing
2905                       (:private '%private-ioblock-write-swapped-u16-encoded-char)
2906                       (:lock '%locked-ioblock-write-swapped-u16-encoded-char)
2907                       (t '%ioblock-write-swapped-u16-encoded-char)))))
2908                (32
2909                 (if (character-encoding-native-endianness encoding)
2910                   (progn
2911                     (setf (ioblock-write-char-when-locked-function ioblock)
2912                           #'%ioblock-write-u32-encoded-char) 
2913                     (case sharing
2914                       (:private #'%private-ioblock-write-u32-encoded-char)
2915                       (:lock #'%locked-ioblock-write-u32-encoded-char)
2916                       (t #'%ioblock-write-u32-encoded-char)))
2917                   (progn
2918                     (setf (ioblock-write-char-when-locked-function ioblock)
2919                           #'%ioblock-write-swapped-u32-encoded-char)
2920                     (case sharing
2921                       (:private #'%private-ioblock-write-swapped-u32-encoded-char)
2922                       (:lock #'%locked-ioblock-write-swapped-u32-encoded-char)
2923                       (t #'%ioblock-write-swapped-u32-encoded-char)))))))
2924        (setf (ioblock-write-simple-string-function ioblock)
2925              (ecase unit-size
2926                (8 '%ioblock-write-u8-encoded-simple-string)
2927                (16
2928                 (if (character-encoding-native-endianness encoding)
2929                   '%ioblock-write-u16-encoded-simple-string
2930                   '%ioblock-write-swapped-u16-encoded-simple-string))
2931                (32
2932                 (if (character-encoding-native-endianness encoding)
2933                   #'%ioblock-write-u32-encoded-simple-string
2934                   #'%ioblock-write-swapped-u32-encoded-simple-string))))
2935        (when (character-encoding-use-byte-order-mark encoding)
2936          (setf (ioblock-pending-byte-order-mark ioblock) t)))
2937      (progn
2938        (setf (ioblock-write-simple-string-function ioblock)
2939              '%ioblock-unencoded-write-simple-string)
2940        (setf (ioblock-write-char-when-locked-function ioblock)
2941              '%ioblock-write-char)
2942        (setf (ioblock-write-char-function ioblock)
2943              (case sharing
2944                (:private '%private-ioblock-write-char)
2945                (:lock '%locked-ioblock-write-char)
2946                (t '%ioblock-write-char)))))
2947    (when line-termination
2948      (install-ioblock-output-line-termination ioblock line-termination)))
2949  (unless (or (eq element-type 'character)
2950              (subtypep element-type 'character))
2951    (let* ((subtag (element-type-subtype element-type)))
2952      (declare (type (unsigned-byte 8) subtag))
2953      (setf (ioblock-write-byte-function ioblock)
2954            (cond ((= subtag target::subtag-u8-vector)
2955                   (progn
2956                     (setf (ioblock-write-byte-when-locked-function ioblock)
2957                           '%ioblock-write-u8-byte)
2958                     (case sharing
2959                       (:private '%private-ioblock-write-u8-byte)
2960                       (:lock '%locked-ioblock-write-u8-byte)
2961                       (t '%ioblock-write-u8-byte))))
2962                  ((= subtag target::subtag-s8-vector)
2963                   (setf (ioblock-write-byte-when-locked-function ioblock)
2964                         '%ioblock-write-s8-byte)                   
2965                   (case sharing
2966                     (:private '%private-ioblock-write-s8-byte)
2967                     (:lock '%locked-ioblock-write-s8-byte)
2968                     (t '%ioblock-write-s8-byte)))
2969                  ((= subtag target::subtag-u16-vector)
2970                   (setf (ioblock-write-byte-when-locked-function ioblock)
2971                         '%ioblock-write-u16-byte)                   
2972                   (case sharing
2973                     (:private '%private-ioblock-write-u16-byte)
2974                     (:lock '%locked-ioblock-write-u16-byte)
2975                     (t '%ioblock-write-u16-byte)))
2976                  ((= subtag target::subtag-s16-vector)
2977                   (setf (ioblock-write-byte-when-locked-function ioblock)
2978                         '%ioblock-write-s16-byte)                                     
2979                   (case sharing
2980                     (:private '%private-ioblock-write-s16-byte)
2981                     (:lock '%locked-ioblock-write-s16-byte)
2982                     (t '%ioblock-write-s16-byte)))
2983                  ((= subtag target::subtag-u32-vector)
2984                   (setf (ioblock-write-byte-when-locked-function ioblock)
2985                         '%ioblock-write-u32-byte)                                     
2986                   (case sharing
2987                     (:private '%private-ioblock-write-u32-byte)
2988                     (:lock '%locked-ioblock-write-u32-byte)
2989                     (t '%ioblock-write-u32-byte)))
2990                  ((= subtag target::subtag-s32-vector)
2991                   (setf (ioblock-write-byte-when-locked-function ioblock)
2992                         '%ioblock-write-s32-byte)
2993                   (case sharing
2994                     (:private '%private-ioblock-write-s32-byte)
2995                     (:lock '%locked-ioblock-write-s32-byte)
2996                     (t '%ioblock-write-s32-byte)))
2997                  #+64-bit-target
2998                  ((= subtag target::subtag-u64-vector)
2999                   (setf (ioblock-write-byte-when-locked-function ioblock)
3000                         '%ioblock-write-u64-byte)
3001                   (case sharing
3002                     (:private '%private-ioblock-write-u64-byte)
3003                     (:lock '%locked-ioblock-write-u64-byte)
3004                     (t '%ioblock-write-u64-byte)))
3005                  #+64-bit-target
3006                  ((= subtag target::subtag-s64-vector)
3007                   (setf (ioblock-write-byte-when-locked-function ioblock)
3008                         '%ioblock-write-u64-byte)
3009                   (case sharing
3010                     (:private '%private-ioblock-write-s64-byte)
3011                     (:lock '%locked-ioblock-write-s64-byte)
3012                     (t '%ioblock-write-s64-byte)))
3013                  (t
3014                   (setf (ioblock-write-byte-when-locked-function ioblock)
3015                         '%general-ioblock-write-byte)                   
3016                   '%general-ioblock-write-byte))))))
3017
3018(defun install-ioblock-output-line-termination (ioblock line-termination)
3019  (let* ((sharing (ioblock-sharing ioblock)))
3020        (when line-termination
3021      (setf (ioblock-write-char-without-translation-when-locked-function ioblock)
3022            (ioblock-write-char-when-locked-function ioblock)
3023            (ioblock-write-simple-string-function ioblock)
3024            '%ioblock-write-simple-string-with-newline-translation)
3025      (ecase line-termination
3026        (:cr (setf (ioblock-write-char-when-locked-function ioblock)
3027                   '%ioblock-write-char-translating-newline-to-cr
3028                   (ioblock-read-char-function ioblock)
3029                   (case sharing
3030                     (:private
3031                      '%private-ioblock-write-char-translating-newline-to-cr)
3032                     (:lock
3033                      '%locked-ioblock-write-char-translating-newline-to-cr)
3034                     (t '%ioblock-write-char-translating-newline-to-cr))))
3035        (:crlf (setf (ioblock-write-char-when-locked-function ioblock)
3036                     '%ioblock-write-char-translating-newline-to-crlf
3037                     (ioblock-write-char-function ioblock)
3038                     (case sharing
3039                       (:private
3040                        '%private-ioblock-write-char-translating-newline-to-crlf)
3041                       (:lock
3042                        '%locked-ioblock-write-char-translating-newline-to-crlf)
3043                       (t '%ioblock-write-char-translating-newline-to-crlf))))
3044        (:unicode (setf (ioblock-write-char-when-locked-function ioblock)
3045                        '%ioblock-write-char-translating-newline-to-line-separator
3046                        (ioblock-write-char-function ioblock)
3047                        (case sharing
3048                          (:private
3049                           '%private-ioblock-write-char-translating-newline-to-line-separator)
3050                          (:lock
3051                           '%locked-ioblock-write-char-translating-newline-to-line-separator)
3052                          (t '%ioblock-write-char-translating-newline-to-line-separator))))))))
3053
3054
3055(defun ensure-reasonable-element-type (element-type)
3056  (let* ((upgraded (upgraded-array-element-type element-type)))
3057    (if (eq upgraded 'bit)
3058      '(unsigned-byte 8)
3059      (if (eq upgraded 'fixnum)
3060        #+64-bit-target '(signed-byte 64) #+32-bit-target '(signed-byte 32)
3061        (if (eq upgraded t)
3062          (error "Stream element-type ~s can't be reasonably supported." element-type)
3063          upgraded)))))
3064
3065(defun init-stream-ioblock (stream
3066                            &key
3067                            insize      ; integer to allocate inbuf here, nil
3068                                        ; otherwise
3069                            outsize     ; integer to allocate outbuf here, nil
3070                                        ; otherwise
3071                            share-buffers-p ; true if input and output
3072                                        ; share a buffer
3073                            element-type
3074                            device
3075                            advance-function
3076                            listen-function
3077                            eofp-function
3078                            force-output-function
3079                            close-function
3080                            element-shift
3081                            interactive
3082                            (sharing :private)
3083                            character-p
3084                            encoding
3085                            line-termination
3086                            input-timeout
3087                            output-timeout
3088                            deadline
3089                            &allow-other-keys)
3090  (declare (ignorable element-shift))
3091  (setq line-termination (cdr (assoc line-termination *canonical-line-termination-conventions*)))
3092  (when encoding
3093    (unless (typep encoding 'character-encoding)
3094      (setq encoding (get-character-encoding encoding)))
3095    (if (eq encoding (get-character-encoding nil))
3096      (setq encoding nil)))
3097  (when sharing
3098    (unless (or (eq sharing :private)
3099                (eq sharing :lock))
3100      (if (eq sharing :external)
3101        (setq sharing nil)
3102        (report-bad-arg sharing '(member nil :private :lock :external)))))
3103  (let* ((ioblock (or (let* ((ioblock (stream-ioblock stream nil)))
3104                        (when ioblock
3105                          (setf (ioblock-stream ioblock) stream)
3106                          ioblock))
3107                      (stream-create-ioblock stream))))
3108    (when (eq sharing :private)
3109      (setf (ioblock-owner ioblock) *current-process*))
3110    (setf (ioblock-encoding ioblock) encoding)
3111    (when insize
3112      (unless (ioblock-inbuf ioblock)
3113        (multiple-value-bind (buffer ptr in-size-in-octets)
3114            (make-heap-ivector insize
3115                               (if character-p
3116                                 '(unsigned-byte 8)
3117                                 (setq element-type
3118                                       (ensure-reasonable-element-type element-type))))
3119          (setf (ioblock-inbuf ioblock)
3120                (make-io-buffer :buffer buffer
3121                                :bufptr ptr
3122                                :size in-size-in-octets
3123                                :limit insize))
3124          (when (eq sharing :lock)
3125            (setf (ioblock-inbuf-lock ioblock) (make-lock)))
3126          (setf (ioblock-line-termination ioblock) line-termination)
3127          (setup-ioblock-input ioblock character-p element-type sharing encoding line-termination)
3128          (setf (ioblock-element-shift ioblock) (max 0 (ceiling (log  (/ in-size-in-octets insize) 2))))
3129          )))
3130    (if share-buffers-p
3131      (if insize
3132        (progn (setf (ioblock-outbuf ioblock)
3133                     (ioblock-inbuf ioblock))
3134               (setf (ioblock-outbuf-lock ioblock)
3135                     (ioblock-inbuf-lock ioblock)))
3136        (error "Can't share buffers unless insize is non-zero and non-null"))
3137      (when outsize
3138        (unless (ioblock-outbuf ioblock)
3139          (multiple-value-bind (buffer ptr out-size-in-octets)
3140              (make-heap-ivector outsize
3141                                 (if character-p
3142                                   '(unsigned-byte 8)
3143                                   (setq element-type (ensure-reasonable-element-type element-type))))
3144            (setf (ioblock-outbuf ioblock)
3145                  (make-io-buffer :buffer buffer
3146                                  :bufptr ptr
3147                                  :count 0
3148                                  :limit outsize
3149                                  :size out-size-in-octets))
3150            (when (eq sharing :lock)
3151              (setf (ioblock-outbuf-lock ioblock) (make-lock)))
3152            (setf (ioblock-element-shift ioblock) (max 0 (ceiling (log (/ out-size-in-octets outsize) 2))))
3153            ))))
3154    (when (or share-buffers-p outsize)
3155      (setup-ioblock-output ioblock character-p element-type sharing encoding line-termination))
3156    (when element-type
3157      (setf (ioblock-element-type ioblock) (if character-p 'character element-type)))
3158;    (when element-shift
3159;      (setf (ioblock-element-shift ioblock) element-shift))
3160    (when device
3161      (setf (ioblock-device ioblock) device))
3162    (when advance-function
3163      (setf (ioblock-advance-function ioblock) advance-function))
3164    (when listen-function
3165      (setf (ioblock-listen-function ioblock) listen-function))
3166    (when eofp-function
3167      (setf (ioblock-eofp-function ioblock) eofp-function))
3168    (when force-output-function
3169      (setf (ioblock-force-output-function ioblock) force-output-function))
3170    (when close-function
3171      (setf (ioblock-close-function ioblock) close-function))
3172    (when interactive
3173      (setf (ioblock-interactive ioblock) interactive))
3174    (setf (stream-ioblock stream) ioblock)
3175    (when encoding
3176      (setf (ioblock-native-byte-order ioblock)
3177            (character-encoding-native-endianness encoding)))
3178    (let* ((bom-info (and insize encoding (character-encoding-use-byte-order-mark encoding))))
3179      (when bom-info
3180        (ioblock-check-input-bom ioblock bom-info sharing)))
3181    (setf (ioblock-input-timeout ioblock) input-timeout)
3182    (setf (ioblock-output-timeout ioblock) output-timeout)
3183    (setf (ioblock-deadline ioblock) deadline)
3184    ioblock))
3185
3186;;; If there's a byte-order-mark (or a reversed byte-order-mark) at
3187;;; the beginning of the input stream, deal with it.  If there's any
3188;;; input present, make sure that we don't write a BOM on output.  If
3189;;; this is a little-endian machine, input data was present, and there
3190;;; was no BOM in that data, make things big-endian.  If there's a
3191;;; leading BOM or swapped BOM, eat it (consume it so that it doesn't
3192;;; ordinarily appear as input.)
3193;;;
3194(defun ioblock-check-input-bom (ioblock swapped-encoding-name sharing)
3195  (let* ((n (%ioblock-advance ioblock nil))) ; try to read, don't block
3196    (when n
3197      (setf (ioblock-pending-byte-order-mark ioblock) nil)
3198      (let* ((inbuf (ioblock-inbuf ioblock))
3199             (unit-size (character-encoding-code-unit-size (ioblock-encoding ioblock)))
3200             (min (ash unit-size -3))
3201             (buf (io-buffer-buffer inbuf))
3202             (swapped-encoding
3203              (and
3204               (>= n min)
3205               (case (case unit-size
3206                       (16 (%native-u8-ref-u16 buf 0))
3207                       (32 (%native-u8-ref-u32 buf 0)))
3208                 (#.byte-order-mark-char-code
3209                  (setf (io-buffer-idx inbuf) min)
3210                  nil)
3211                 (#.swapped-byte-order-mark-char-code
3212                  (setf (io-buffer-idx inbuf) min)
3213                  t)
3214                 (t #+little-endian-target t))
3215               (lookup-character-encoding swapped-encoding-name))))
3216        (when swapped-encoding
3217          (let* ((output-p (not (null (ioblock-outbuf ioblock)))))
3218            (setf (ioblock-native-byte-order ioblock)
3219                  (character-encoding-native-endianness swapped-encoding))
3220            (ecase unit-size
3221              (16
3222               (setf (ioblock-read-char-when-locked-function ioblock)
3223                     '%ioblock-read-swapped-u16-encoded-char)
3224               (case sharing
3225                 (:private '%private-ioblock-read-swapped-u16-encoded-char)
3226                 (:lock '%locked-ioblock-read-swapped-u16-encoded-char)
3227                 (t '%ioblock-read-swapped-u16-encoded-char)))
3228              (32
3229               (setf (ioblock-read-char-when-locked-function ioblock)
3230                     '%ioblock-read-swapped-u32-encoded-char)
3231               (case sharing
3232                 (:private '%private-ioblock-read-swapped-u32-encoded-char)
3233                 (:lock '%locked-ioblock-read-swapped-u32-encoded-char)
3234                 (t '%ioblock-read-swapped-u16-encoded-char))))
3235            (when output-p
3236              (ecase unit-size
3237                (16
3238                 (setf (ioblock-write-char-when-locked-function ioblock)
3239                       '%ioblock-write-swapped-u16-encoded-char)
3240                 (case sharing
3241                   (:private '%private-ioblock-write-swapped-u16-encoded-char)
3242                   (:lock '%locked-ioblock-write-swapped-u16-encoded-char)
3243                   (t '%ioblock-write-swapped-u16-encoded-char))
3244                 (setf (ioblock-write-simple-string-function ioblock)
3245                       '%ioblock-write-swapped-u16-encoded-simple-string))
3246                (32
3247                 (setf (ioblock-write-char-when-locked-function ioblock)
3248                       '%ioblock-write-swapped-u32-encoded-char)
3249                 (case sharing
3250                   (:private '%private-ioblock-write-swapped-u32-encoded-char)
3251                   (:lock '%locked-ioblock-write-swapped-u32-encoded-char)
3252                   (t '%ioblock-write-swapped-u32-encoded-char))
3253                 (setf (ioblock-write-simple-string-function ioblock)
3254                       '%ioblock-write-swapped-u32-encoded-simple-string))))))))))
3255
3256
3257
3258;;; We can't define a MAKE-INSTANCE method on STRUCTURE-CLASS subclasses
3259;;; in MCL; of course, calling the structure-class's constructor does
3260;;; much the same thing (but note that MCL only keeps track of the
3261;;; default, automatically generated constructor.)
3262;;; (As fascinating as that may be, that has nothing to do with any
3263;;; nearby code, though it may have once been relevant.)
3264(defun make-ioblock-stream (class
3265                            &rest initargs
3266                            &key 
3267                            &allow-other-keys)
3268  (declare (dynamic-extent initargs))
3269  (let* ((s
3270          (if (subtypep class (find-class 'basic-stream))
3271            (apply #'make-basic-stream-instance class :allow-other-keys t initargs)
3272            (apply #'make-instance class :allow-other-keys t initargs))))
3273    (apply #'init-stream-ioblock s initargs)
3274    s))
3275
3276
3277
3278
3279
3280(defmethod select-stream-class ((s symbol) in-p out-p char-p)
3281  (select-stream-class (class-prototype (find-class s)) in-p out-p char-p))
3282
3283(defmethod select-stream-class ((s structure-class) in-p out-p char-p)
3284  (select-stream-class (class-prototype s) in-p out-p char-p))
3285
3286(defmethod select-stream-class ((s standard-class) in-p out-p char-p)
3287  (select-stream-class (class-prototype s) in-p out-p char-p))
3288
3289
3290(defparameter *canonical-line-termination-conventions*
3291  '((:unix . nil)
3292    (:macos . :cr)
3293    (:cr . :cr)
3294    (:crlf . :crlf)
3295    (:cp/m . :crlf)
3296    (:msdos . :crlf)
3297    (:dos . :crlf)
3298    (:windows . :crlf)
3299    (:inferred . nil)
3300    (:unicode . :unicode)))
3301
3302
3303(defun optimal-buffer-size (fd element-type)
3304  (let* ((nominal (or (nth-value 6 (%fstat fd)) *elements-per-buffer*))
3305         (octets (case (%unix-fd-kind fd)
3306                   (:pipe (#_fpathconf fd #$_PC_PIPE_BUF))
3307                   (:socket
3308                    #+linux-target nominal
3309                    #-linux-target 
3310                    (int-getsockopt fd #$SOL_SOCKET #$SO_SNDLOWAT))
3311                   ((:character-special :tty) (#_fpathconf fd #$_PC_MAX_INPUT))
3312                   (t nominal))))
3313    (case (subtag-bytes (element-type-subtype element-type) 1)
3314      (1 octets)
3315      (2 (ash octets -1))
3316      (4 (ash octets -2))
3317      (8 (ash octets -3)))))
3318
3319
3320(defun milliseconds-until-deadline (deadline ioblock)
3321  (let* ((now (get-internal-real-time)))
3322    (if (> now deadline)
3323      (error 'communication-deadline-expired :stream (ioblock-stream ioblock))
3324      (values (round (- deadline now) (/ internal-time-units-per-second 1000))))))
3325
3326
3327;;; Note that we can get "bivalent" streams by specifiying :character-p t
3328;;; with a reasonable element-type (e.g. (UNSIGNED-BYTE 8))
3329(defun make-fd-stream (fd &key
3330                          (direction :input)
3331                          (interactive t)
3332                          (element-type 'character)
3333                          (class 'fd-stream)
3334                          (sharing :private)
3335                          (character-p (or (eq element-type 'character)
3336                                           (subtypep element-type 'character)))
3337                          (basic nil)
3338                          encoding
3339                          line-termination
3340                          auto-close
3341                          input-timeout
3342                          output-timeout
3343                          deadline)
3344  (let* ((elements-per-buffer (optimal-buffer-size fd element-type)))
3345    (when line-termination
3346      (setq line-termination
3347            (cdr (assoc line-termination *canonical-line-termination-conventions*))))
3348    (when basic
3349      (setq class (map-to-basic-stream-class-name class))
3350      (setq basic (subtypep (find-class class) 'basic-stream)))
3351    (let* ((in-p (member direction '(:io :input)))
3352           (out-p (member direction '(:io :output)))
3353           (class-name (select-stream-class class in-p out-p character-p))
3354           (class (find-class class-name))
3355           (stream
3356            (make-ioblock-stream class
3357                                 :insize (if in-p elements-per-buffer)
3358                                 :outsize (if out-p elements-per-buffer)
3359                                 :device fd
3360                                 :interactive interactive
3361                                 :element-type element-type
3362                                 :advance-function (if in-p
3363                                                     (select-stream-advance-function class direction))
3364                                 :listen-function (if in-p 'fd-stream-listen)
3365                                 :eofp-function (if in-p 'fd-stream-eofp)
3366                                 :force-output-function (if out-p
3367                                                          (select-stream-force-output-function class direction))
3368                                 :close-function 'fd-stream-close
3369                                 :sharing sharing
3370                                 :character-p character-p
3371                                 :encoding encoding
3372                                 :line-termination line-termination
3373                                 :input-timeout input-timeout
3374                                 :output-timeout output-timeout
3375                                 :deadline deadline)))
3376      (if auto-close
3377        (terminate-when-unreachable stream
3378                                    (lambda (stream)
3379                                      (close-for-termination stream t))))
3380      stream)))
3381
3382 
3383;;;  Fundamental streams.
3384
3385(defclass fundamental-stream (stream)
3386    ())
3387
3388(defclass fundamental-input-stream (fundamental-stream input-stream)
3389    ((shared-resource :initform nil :accessor input-stream-shared-resource)))
3390
3391(defclass fundamental-output-stream (fundamental-stream output-stream)
3392    ())
3393
3394(defmethod input-stream-p ((x t))
3395  (report-bad-arg x 'stream))
3396                           
3397(defmethod input-stream-p ((s input-stream))
3398  t)
3399
3400(defmethod output-stream-p ((x t))
3401  (report-bad-arg x 'stream))
3402
3403(defmethod output-stream-p ((s input-stream))
3404  (typep s 'output-stream))
3405
3406(defmethod output-stream-p ((s output-stream))
3407  t)
3408
3409(defmethod input-stream-p ((s output-stream))
3410  (typep s 'input-stream))
3411
3412(defclass binary-stream (stream)
3413    ())
3414
3415(defclass character-stream (stream)
3416    ())
3417
3418(defmethod stream-external-format ((s character-stream))
3419  (make-external-format :character-encoding #+big-endian-target :utf32-be #+little-endian-target :utf32-le :line-termination :unix))
3420
3421
3422(defmethod (setf stream-external-format) (new (s character-stream))
3423  (check-type new 'external-format)
3424  (stream-external-format s))
3425
3426
3427(defclass fundamental-character-stream (fundamental-stream character-stream)
3428    ())
3429
3430(defmethod stream-element-type ((s fundamental-character-stream))
3431  'character)
3432
3433(defclass fundamental-binary-stream (fundamental-stream binary-stream)
3434    ())
3435
3436(defclass character-input-stream (input-stream character-stream)
3437    ())
3438
3439(defclass fundamental-character-input-stream (fundamental-input-stream
3440                                              fundamental-character-stream
3441                                              character-input-stream)
3442    ())
3443
3444(defmethod stream-read-char-no-hang ((s fundamental-character-input-stream))
3445  (stream-read-char s))
3446
3447(defmethod stream-peek-char ((s fundamental-character-input-stream))
3448  (let* ((ch (stream-read-char s)))
3449    (unless (eq ch :eof)
3450      (stream-unread-char s ch))
3451    ch))
3452
3453(defmethod stream-listen ((s fundamental-character-input-stream))
3454  (let* ((ch (stream-read-char-no-hang s)))
3455    (when (and ch (not (eq ch :eof)))
3456      (stream-unread-char s ch))
3457    ch))
3458
3459(defmethod stream-clear-input ((s fundamental-character-input-stream))
3460  )
3461
3462(defmethod stream-read-line ((s character-input-stream))
3463  (generic-read-line s))
3464
3465(defclass character-output-stream (output-stream character-stream)
3466    ())
3467
3468(defclass fundamental-character-output-stream (fundamental-output-stream
3469                                               fundamental-character-stream
3470                                               character-output-stream)
3471    ())
3472
3473(defclass binary-input-stream (input-stream binary-stream)
3474    ())
3475
3476(defclass fundamental-binary-input-stream (fundamental-input-stream
3477                                           fundamental-binary-stream
3478                                           binary-input-stream)
3479    ())
3480
3481(defclass binary-output-stream (output-stream binary-stream)
3482    ())
3483
3484(defclass fundamental-binary-output-stream (fundamental-output-stream
3485                                            fundamental-binary-stream
3486                                            binary-output-stream)
3487    ())
3488
3489
3490
3491(defmethod stream-read-byte ((s t))
3492  (report-bad-arg s '(and input-stream binary-stream)))
3493
3494(defmethod stream-write-byte ((s t) b)
3495  (declare (ignore b))
3496  (report-bad-arg s '(and output-stream binary-stream)))
3497
3498(defmethod stream-length ((s stream) &optional new)
3499  (declare (ignore new)))
3500
3501(defmethod stream-start-line-p ((s character-output-stream))
3502  (eql 0 (stream-line-column s)))
3503
3504(defmethod stream-terpri ((s character-output-stream))
3505  (stream-write-char s #\Newline))
3506
3507(defmethod stream-fresh-line ((s character-output-stream))
3508  (unless (stream-start-line-p s)
3509    (stream-terpri s)
3510    t))
3511
3512;;; The bad news is that this doesn't even bother to do the obvious
3513;;; (calling STREAM-WRITE-STRING with a longish string of spaces.)
3514;;; The good news is that this method is pretty useless to (format "~T" ...)
3515;;; anyhow.
3516(defmethod stream-advance-to-column ((s fundamental-character-output-stream)
3517                                     col)
3518  (generic-advance-to-column s col))
3519
3520(defmethod stream-write-string ((stream fundamental-character-output-stream) string &optional (start 0) end)
3521  (generic-stream-write-string stream string start end))
3522
3523
3524;;; The read-/write-vector methods could be specialized for stream classes
3525;;; that expose the underlying buffering mechanism.
3526;;; They can assume that the 'vector' argument is a simple one-dimensional
3527;;; array and that the 'start' and 'end' arguments are sane.
3528
3529(defmethod stream-write-vector ((stream character-output-stream)
3530                                vector start end)
3531  (declare (fixnum start end))
3532  (do* ((i start (1+ i)))
3533       ((= i end))
3534    (declare (fixnum i))
3535    (write-char (uvref vector i) stream)))
3536
3537(defmethod stream-write-vector ((stream binary-output-stream)
3538                                vector start end)
3539  (declare (fixnum start end))
3540  (do* ((i start (1+ i)))
3541       ((= i end))
3542    (declare (fixnum i))
3543    (write-byte (uvref vector i) stream)))
3544
3545(defmethod stream-read-vector ((stream character-input-stream)
3546                               vector start end)
3547  (generic-character-read-vector stream vector start end))
3548
3549
3550(defmethod stream-read-vector ((stream binary-input-stream)
3551                               vector start end)
3552  (declare (fixnum start end))
3553  (do* ((i start (1+ i)))
3554       ((= i end) end)
3555    (declare (fixnum i))
3556    (let* ((b (read-byte stream nil :eof)))
3557      (if (eq b :eof)
3558        (return i)
3559        (setf (uvref vector i) b)))))
3560
3561
3562
3563
3564;;; File streams, in the abstract.
3565
3566(defclass file-stream (stream)
3567    ())
3568
3569(defmethod stream-domain ((s file-stream))
3570  :file)
3571
3572
3573
3574;;; "Basic" (non-extensible) streams.
3575
3576
3577(declaim (inline basic-stream-p))
3578
3579(defun basic-stream-p (x)
3580  (= (the fixnum (typecode x)) target::subtag-basic-stream))
3581
3582(setf (type-predicate 'basic-stream) 'basic-stream-p)
3583
3584(make-built-in-class 'basic-stream 'stream)
3585(make-built-in-class 'basic-file-stream 'basic-stream 'file-stream)
3586(make-built-in-class 'basic-character-stream 'basic-stream 'character-stream)
3587(make-built-in-class 'basic-binary-stream 'basic-stream 'binary-stream)
3588
3589(make-built-in-class 'basic-input-stream 'basic-stream 'input-stream)
3590(make-built-in-class 'basic-output-stream 'basic-stream 'output-stream)
3591(make-built-in-class 'basic-io-stream 'basic-input-stream 'basic-output-stream)
3592(make-built-in-class 'basic-character-input-stream 'basic-input-stream 'basic-character-stream 'character-input-stream)
3593(make-built-in-class 'basic-character-output-stream 'basic-output-stream 'basic-character-stream 'character-output-stream)
3594(make-built-in-class 'basic-character-io-stream 'basic-character-input-stream 'basic-character-output-stream)
3595(make-built-in-class 'basic-binary-input-stream 'basic-input-stream 'basic-binary-stream 'binary-input-stream)
3596(make-built-in-class 'basic-binary-output-stream 'basic-output-stream 'basic-binary-stream 'binary-output-stream)
3597(make-built-in-class 'basic-binary-io-stream 'basic-binary-input-stream 'basic-binary-output-stream)
3598
3599
3600(defun %ioblock-external-format (ioblock)
3601  (let* ((encoding (or (ioblock-encoding ioblock)
3602                       (get-character-encoding nil)))
3603         (line-termination (or (ioblock-line-termination ioblock)
3604                               :unix)))
3605    (make-external-format :character-encoding (character-encoding-name encoding)
3606                          :line-termination line-termination)))
3607
3608(defmethod input-stream-shared-resource ((s basic-input-stream))
3609  (getf (basic-stream.info s) :shared-resource))
3610
3611(defmethod (setf input-stream-shared-resource) (new (s basic-input-stream))
3612  (setf (getf (basic-stream.info s) :shared-resource) new))
3613
3614(defmethod print-object ((s basic-stream) out)
3615  (print-unreadable-object (s out :type t :identity t)
3616    (let* ((ioblock (basic-stream.state s))
3617           (fd (and ioblock (ioblock-device ioblock)))
3618           (encoding (and ioblock (encoding-name (ioblock-encoding ioblock)))))
3619      (if fd
3620        (format out "~a (~a/~d)" encoding (%unix-fd-kind fd) fd)
3621        (format out "~s" :closed)))))
3622
3623(defmethod select-stream-class ((s (eql 'basic-stream)) in-p out-p char-p)
3624  (if char-p
3625    (if in-p
3626      (if out-p
3627        'basic-character-io-stream
3628        'basic-character-input-stream)
3629      'basic-character-output-stream)
3630    (if in-p
3631      (if out-p
3632        'basic-binary-io-stream
3633        'basic-binary-input-stream)
3634      'basic-binary-output-stream)))
3635
3636
3637(defmethod map-to-basic-stream-class-name (name)
3638  name)
3639
3640(defmethod map-to-basic-stream-class-name ((name (eql 'fd-stream)))
3641  'basic-stream)
3642
3643(defun allocate-basic-stream (class)
3644  (if (subtypep class 'basic-file-stream)
3645    (gvector :basic-stream class 0 nil nil nil nil nil)
3646    (gvector :basic-stream class 0 nil nil)))
3647
3648
3649(defmethod initialize-basic-stream ((s basic-stream) &key &allow-other-keys)
3650  )
3651 
3652(defmethod initialize-basic-stream :after  ((s basic-input-stream) &key &allow-other-keys)
3653  (setf (basic-stream.flags s)
3654        (logior (ash 1 basic-stream-flag.open-input) (basic-stream.flags s))))
3655
3656(defmethod initialize-basic-stream :after ((s basic-output-stream) &key &allow-other-keys)
3657  (setf (basic-stream.flags s)
3658        (logior (ash 1 basic-stream-flag.open-output) (basic-stream.flags s))))
3659
3660(defmethod initialize-basic-stream :after ((s basic-binary-stream) &key &allow-other-keys)
3661  (setf (basic-stream.flags s)
3662        (logior (ash 1 basic-stream-flag.open-binary) (basic-stream.flags s))))
3663
3664(defmethod initialize-basic-stream :after ((s basic-character-stream) &key &allow-other-keys)
3665  (setf (basic-stream.flags s)
3666        (logior (ash 1 basic-stream-flag.open-character) (basic-stream.flags s))))
3667
3668(defun make-basic-stream-instance (class &rest initargs)
3669  (let* ((s (allocate-basic-stream class)))
3670    (apply #'initialize-basic-stream s initargs)
3671    s))
3672
3673
3674
3675(defmethod (setf stream-ioblock) (ioblock (s basic-stream))
3676  (setf (basic-stream.state s) ioblock))
3677
3678(defmethod stream-create-ioblock ((stream basic-stream) &rest args &key)
3679  (declare (dynamic-extent args))
3680  (apply #'make-ioblock :stream stream args))
3681
3682
3683(defmethod stream-write-list ((stream fundamental-character-output-stream)
3684                              list count)
3685  (declare (fixnum count))
3686  (dotimes (i count)
3687    (stream-write-char stream (pop list))))
3688
3689(defmethod stream-write-list ((stream basic-character-output-stream)
3690                              list count)
3691  (declare (fixnum count))
3692  (dotimes (i count)
3693    (stream-write-char stream (pop list))))
3694
3695(defmethod stream-read-list ((stream character-input-stream)
3696                             list count)
3697  (generic-character-read-list stream list count))
3698
3699
3700(defmethod stream-write-list ((stream fundamental-binary-output-stream)
3701                              list count)
3702  (declare (fixnum count))
3703  (dotimes (i count)
3704    (let* ((element (pop list)))
3705      (if (typep element 'character)
3706        (write-char element stream)
3707        (write-byte element stream)))))
3708
3709(defmethod stream-write-list ((stream basic-binary-output-stream)
3710                              list count)
3711  (declare (fixnum count))
3712  (dotimes (i count)
3713    (let* ((element (pop list)))
3714      (if (typep element 'character)
3715        (write-char element stream)
3716        (write-byte element stream)))))
3717
3718(defmethod stream-read-list ((stream binary-input-stream)
3719                             list count)
3720  (declare (fixnum count))
3721  (do* ((tail list (cdr tail))
3722        (i 0 (1+ i)))
3723       ((= i count) count)
3724    (declare (fixnum i))
3725    (let* ((b (read-byte stream nil :eof)))
3726      (if (eq b :eof)
3727        (return i)
3728        (rplaca tail b)))))
3729
3730
3731
3732
3733
3734
3735
3736(defun stream-is-closed (s)
3737  (error "~s is closed" s))
3738
3739(defmethod stream-read-char ((s basic-character-input-stream))
3740  (let* ((ioblock (basic-stream-ioblock s)))
3741    (funcall (ioblock-read-char-function ioblock) ioblock)))
3742
3743
3744(defmethod stream-read-char-no-hang ((stream basic-character-input-stream))
3745  (let* ((ioblock (basic-stream-ioblock stream)))
3746    (with-ioblock-input-locked (ioblock)
3747      (values
3748          (%ioblock-tyi-no-hang ioblock)))))
3749       
3750(defmethod stream-peek-char ((stream basic-character-input-stream))
3751  (let* ((ioblock (basic-stream-ioblock stream)))
3752    (with-ioblock-input-locked (ioblock)
3753      (values
3754       (funcall (ioblock-peek-char-function ioblock) ioblock)))))
3755
3756(defmethod stream-clear-input ((stream basic-character-input-stream))
3757  (let* ((ioblock (basic-stream-ioblock stream)))
3758    (with-ioblock-input-locked (ioblock)
3759      (values
3760        (%ioblock-clear-input ioblock)))))
3761
3762(defmethod stream-unread-char ((s basic-character-input-stream) char)
3763  (let* ((ioblock (basic-stream-ioblock s)))
3764    (with-ioblock-input-locked (ioblock)
3765      (values
3766       (funcall (ioblock-unread-char-function ioblock) ioblock char)))))
3767
3768(defmethod stream-read-ivector ((s basic-binary-input-stream)
3769                                iv start nb)
3770  (let* ((ioblock (basic-stream-ioblock s)))
3771    (with-ioblock-input-locked (ioblock)
3772      (values
3773       (%ioblock-binary-in-ivect ioblock iv start nb)))))
3774
3775(defmethod stream-read-vector ((stream basic-character-input-stream)
3776                               vector start end)
3777  (declare (fixnum start end))
3778  (if (not (typep vector 'simple-base-string))
3779    (generic-character-read-vector stream vector start end)
3780    (let* ((ioblock (basic-stream-ioblock stream)))
3781      (with-ioblock-input-locked (ioblock)
3782        (values
3783         (funcall (ioblock-character-read-vector-function ioblock)
3784                  ioblock vector start end))))))
3785
3786(defmethod stream-read-line ((stream basic-character-input-stream))
3787  (let* ((ioblock (basic-stream-ioblock stream)))
3788    (with-ioblock-input-locked (ioblock)
3789      (funcall (ioblock-read-line-function ioblock) ioblock))))
3790
3791                             
3792;;; Synonym streams.
3793
3794(defclass synonym-stream (fundamental-stream)
3795    ((symbol :initarg :symbol :reader synonym-stream-symbol)))
3796
3797(defmethod print-object ((s synonym-stream) out)
3798  (print-unreadable-object (s out :type t :identity t)
3799    (format out "to ~s" (synonym-stream-symbol s))))
3800
3801(macrolet ((synonym-method (name &rest args)
3802            (let* ((stream (make-symbol "STREAM")))
3803              `(defmethod ,name ((,stream synonym-stream) ,@args)
3804                (,name (symbol-value (synonym-stream-symbol ,stream)) ,@args)))))
3805           (synonym-method stream-read-char)
3806           (synonym-method stream-read-byte)
3807           (synonym-method stream-unread-char c)
3808           (synonym-method stream-read-char-no-hang)
3809           (synonym-method stream-peek-char)
3810           (synonym-method stream-listen)
3811           (synonym-method stream-eofp)
3812           (synonym-method stream-clear-input)
3813           (synonym-method stream-read-line)
3814           (synonym-method stream-read-list l c)
3815           (synonym-method stream-read-vector v start end)
3816           (synonym-method stream-write-char c)
3817           ;(synonym-method stream-write-string str &optional (start 0) end)
3818           (synonym-method stream-write-byte b)
3819           (synonym-method stream-clear-output)
3820           (synonym-method stream-line-column)
3821           (synonym-method stream-set-column new)
3822           (synonym-method stream-advance-to-column new)
3823           (synonym-method stream-start-line-p)
3824           (synonym-method stream-fresh-line)
3825           (synonym-method stream-terpri)
3826           (synonym-method stream-force-output)
3827           (synonym-method stream-finish-output)
3828           (synonym-method stream-write-list l c)
3829           (synonym-method stream-write-vector v start end)
3830           (synonym-method stream-element-type)
3831           (synonym-method input-stream-p)
3832           (synonym-method output-stream-p)
3833           (synonym-method interactive-stream-p)
3834           (synonym-method stream-direction)
3835           (synonym-method stream-device direction)
3836           (synonym-method stream-surrounding-characters)
3837           (synonym-method stream-input-timeout)
3838           (synonym-method stream-output-timeout)
3839           (synonym-method stream-deadline))
3840
3841(defmethod (setf input-stream-timeout) (new (s synonym-stream))
3842  (setf (input-stream-timeout (symbol-value (synonym-stream-symbol s))) new))
3843
3844(defmethod (setf output-stream-timeout) (new (s synonym-stream))
3845  (setf (output-stream-timeout (symbol-value (synonym-stream-symbol s))) new))
3846
3847
3848(defmethod stream-write-string ((s synonym-stream) string &optional (start 0) end)
3849  (stream-write-string (symbol-value (synonym-stream-symbol s)) string start end))
3850
3851(defmethod stream-length ((s synonym-stream) &optional new)
3852  (stream-length (symbol-value (synonym-stream-symbol s)) new))
3853
3854(defmethod stream-position ((s synonym-stream) &optional new)
3855  (stream-position (symbol-value (synonym-stream-symbol s)) new))
3856
3857(defun make-synonym-stream (symbol)
3858  (make-instance 'synonym-stream :symbol (require-type symbol 'symbol)))
3859
3860;;;
3861(defclass composite-stream-mixin ()
3862    ((open-p :initform t)))
3863
3864(defmethod close :after ((stream composite-stream-mixin) &key abort)
3865  (declare (ignore abort))
3866  (with-slots (open-p) stream
3867    (setq open-p nil)))
3868
3869(defmethod open-stream-p ((stream composite-stream-mixin))
3870  (slot-value stream 'open-p))
3871
3872
3873;;; Two-way streams.
3874(defclass two-way-stream (composite-stream-mixin fundamental-input-stream fundamental-output-stream)
3875    ((input-stream :initarg :input-stream :accessor two-way-stream-input-stream)
3876     (output-stream :initarg :output-stream :accessor two-way-stream-output-stream)))
3877
3878(defmethod print-object ((s two-way-stream) out)
3879  (print-unreadable-object (s out :type t :identity t)
3880    (format out "input ~s, output ~s" 
3881            (two-way-stream-input-stream s)
3882            (two-way-stream-output-stream s))))
3883
3884(macrolet ((two-way-input-method (name &rest args)
3885             (let* ((stream (make-symbol "STREAM")))
3886               `(defmethod ,name ((,stream two-way-stream) ,@args)
3887                 (,name (two-way-stream-input-stream ,stream) ,@args))))
3888           (two-way-output-method (name &rest args)
3889             (let* ((stream (make-symbol "STREAM")))
3890               `(defmethod ,name ((,stream two-way-stream) ,@args)
3891                 (,name (two-way-stream-output-stream ,stream) ,@args)))))
3892  (two-way-input-method stream-read-char)
3893  (two-way-input-method stream-read-byte)
3894  (two-way-input-method stream-unread-char c)
3895  (two-way-input-method stream-read-char-no-hang)
3896  (two-way-input-method stream-peek-char)
3897  (two-way-input-method stream-listen)
3898  (two-way-input-method stream-eofp)
3899  (two-way-input-method stream-clear-input)
3900  (two-way-input-method stream-read-line)
3901  (two-way-input-method stream-read-list l c)
3902  (two-way-input-method stream-read-vector v start end)
3903  (two-way-input-method stream-surrounding-characters)
3904  (two-way-input-method stream-input-timeout)
3905  (two-way-output-method stream-write-char c)
3906  (two-way-output-method stream-write-byte b)
3907  (two-way-output-method stream-clear-output)
3908  (two-way-output-method stream-line-column)
3909  (two-way-output-method stream-set-column new)
3910  (two-way-output-method stream-advance-to-column new)
3911  (two-way-output-method stream-start-line-p)
3912  (two-way-output-method stream-fresh-line)
3913  (two-way-output-method stream-terpri)
3914  (two-way-output-method stream-force-output)
3915  (two-way-output-method stream-finish-output)
3916  (two-way-output-method stream-write-list l c)
3917  (two-way-output-method stream-write-vector v start end)
3918  (two-way-output-method stream-output-timeout)
3919  (two-way-output-method stream-deadline))
3920
3921(defmethod (setf stream-input-timeout) (new (s two-way-stream))
3922  (setf (stream-input-timeout (two-way-stream-input-stream s)) new))
3923
3924(defmethod (setf stream-output-timeout) (new (s two-way-stream))
3925  (setf (stream-output-timeout (two-way-stream-output-stream s)) new))
3926
3927(defmethod (setf stream-deadline) (new (s two-way-stream))
3928  (setf (stream-deadline (two-way-stream-output-stream s)) new))
3929
3930(defmethod stream-device ((s two-way-stream) direction)
3931  (case direction
3932    (:input (stream-device (two-way-stream-input-stream s) direction))
3933    (:output (stream-device (two-way-stream-output-stream s) direction))))
3934   
3935(defmethod stream-write-string ((s two-way-stream) string &optional (start 0) end)
3936  (stream-write-string (two-way-stream-output-stream s) string start end))
3937
3938(defmethod stream-element-type ((s two-way-stream))
3939  (let* ((in-type (stream-element-type (two-way-stream-input-stream s)))
3940         (out-type (stream-element-type (two-way-stream-output-stream s))))
3941    (if (equal in-type out-type)
3942      in-type
3943      `(and ,in-type ,out-type))))
3944
3945(defun make-two-way-stream (in out)
3946  "Return a bidirectional stream which gets its input from INPUT-STREAM and
3947   sends its output to OUTPUT-STREAM."
3948  (unless (input-stream-p in)
3949    (require-type in 'input-stream))
3950  (unless (output-stream-p out)
3951    (require-type out 'output-stream))
3952  (make-instance 'two-way-stream :input-stream in :output-stream out))
3953
3954;;; This is intended for use with things like *TERMINAL-IO*, where the
3955;;; OS echoes interactive input.  Whenever we read a character from
3956;;; the underlying input-stream of such a stream, we need to update
3957;;; our notion of the underlying output-stream's STREAM-LINE-COLUMN.
3958
3959(defclass echoing-two-way-stream (two-way-stream)
3960    ())
3961
3962(defmethod stream-read-char ((s echoing-two-way-stream))
3963  (let* ((out (two-way-stream-output-stream s))
3964         (in (two-way-stream-input-stream s)))
3965    (force-output out)
3966    (let* ((ch (stream-read-char in)))
3967      (unless (eq ch :eof)
3968        (if (eq ch #\newline)
3969          (stream-set-column out 0)
3970          (let* ((cur (stream-line-column out)))
3971            (when cur
3972              (stream-set-column out (1+ (the fixnum cur)))))))
3973      ch)))
3974
3975(defmethod stream-read-line ((s echoing-two-way-stream))
3976  (let* ((out (two-way-stream-output-stream s)))
3977    (multiple-value-bind (string eof)
3978        (call-next-method)
3979      (unless eof
3980        (stream-set-column out 0))
3981      (values string eof))))
3982
3983(defun make-echoing-two-way-stream (in out)
3984  (make-instance 'echoing-two-way-stream :input-stream in :output-stream out))
3985
3986;;;echo streams
3987
3988(defclass echo-stream (two-way-stream)
3989    ((did-untyi :initform nil)))
3990
3991(defmethod echo-stream-input-stream ((s echo-stream))
3992  (two-way-stream-input-stream s))
3993
3994(defmethod echo-stream-output-stream ((s echo-stream))
3995  (two-way-stream-output-stream s))
3996
3997(defmethod stream-read-char ((s echo-stream))
3998  (let* ((char (stream-read-char (echo-stream-input-stream s))))
3999    (unless (eq char :eof)
4000      (if (slot-value s 'did-untyi)
4001        (setf (slot-value s 'did-untyi) nil)
4002        (stream-write-char (echo-stream-output-stream s) char)))
4003    char))
4004
4005(defmethod stream-unread-char ((s echo-stream) c)
4006  (call-next-method s c)
4007  (setf (slot-value s 'did-untyi) c))
4008
4009(defmethod stream-read-char-no-hang ((s echo-stream))
4010  (let* ((char (stream-read-char-no-hang (echo-stream-input-stream s))))
4011    (unless (eq char :eof)
4012      (if (slot-value s 'did-untyi)
4013        (setf (slot-value s 'did-untyi) nil)
4014        (stream-write-char (echo-stream-output-stream s) char)))
4015    char))
4016
4017(defmethod stream-clear-input ((s echo-stream))
4018  (call-next-method)
4019  (setf (slot-value s 'did-untyi) nil))
4020
4021(defmethod stream-read-byte ((s echo-stream))
4022  (let* ((byte (stream-read-byte (echo-stream-input-stream s))))
4023    (unless (eq byte :eof)
4024      (stream-write-byte (echo-stream-output-stream s) byte))
4025    byte))
4026
4027(defmethod stream-read-line ((s echo-stream))
4028  (generic-read-line s))
4029
4030(defmethod stream-read-vector ((s echo-stream) vector start end)
4031  (if (subtypep (stream-element-type s) 'character)
4032      (generic-character-read-vector s vector start end)
4033    (generic-binary-read-vector s vector start end)))
4034
4035(defun make-echo-stream (input-stream output-stream)
4036  "Return a bidirectional stream which gets its input from INPUT-STREAM and
4037   sends its output to OUTPUT-STREAM. In addition, all input is echoed to
4038   the output stream."
4039  (make-instance 'echo-stream
4040                 :input-stream input-stream
4041                 :output-stream output-stream))
4042
4043;;;concatenated-streams
4044
4045(defclass concatenated-stream (composite-stream-mixin fundamental-input-stream)
4046    ((streams :initarg :streams :accessor concatenated-stream-streams)))
4047
4048
4049(defun concatenated-stream-current-input-stream (s)
4050  (car (concatenated-stream-streams s)))
4051
4052(defun concatenated-stream-next-input-stream (s)
4053  (setf (concatenated-stream-streams s)
4054        (cdr (concatenated-stream-streams s)))
4055  (concatenated-stream-current-input-stream s))
4056
4057(defmethod stream-element-type ((s concatenated-stream))
4058  (let* ((c (concatenated-stream-current-input-stream s)))
4059    (if c
4060      (stream-element-type c)
4061      nil)))
4062
4063
4064
4065(defmethod stream-read-char ((s concatenated-stream))
4066  (do* ((c (concatenated-stream-current-input-stream s)
4067           (concatenated-stream-next-input-stream s)))
4068       ((null c) :eof)
4069    (let* ((ch (stream-read-char c)))
4070      (unless (eq ch :eof)
4071        (return ch)))))
4072
4073(defmethod stream-read-char-no-hang ((s concatenated-stream))
4074  (do* ((c (concatenated-stream-current-input-stream s)
4075           (concatenated-stream-next-input-stream s)))
4076       ((null c) :eof)
4077    (let* ((ch (stream-read-char-no-hang c)))
4078      (unless (eq ch :eof)
4079        (return ch)))))
4080
4081(defmethod stream-read-byte ((s concatenated-stream))
4082  (do* ((c (concatenated-stream-current-input-stream s)
4083           (concatenated-stream-next-input-stream s)))
4084       ((null c) :eof)
4085    (let* ((b (stream-read-byte c)))
4086      (unless (eq b :eof)
4087        (return b)))))
4088
4089(defmethod stream-peek-char ((s concatenated-stream))
4090  (do* ((c (concatenated-stream-current-input-stream s)
4091       (concatenated-stream-next-input-stream s)))
4092       ((null c) :eof)
4093    (let* ((ch (stream-peek-char c)))
4094      (unless (eq ch :eof)
4095        (return ch)))))
4096
4097(defmethod stream-read-line ((s concatenated-stream))
4098  (generic-read-line s))
4099
4100(defmethod stream-read-list ((s concatenated-stream) list count)
4101  (generic-character-read-list s list count))
4102
4103(defmethod stream-read-vector ((s concatenated-stream) vector start end)
4104  (if (subtypep (stream-element-type s) 'character)
4105      (generic-character-read-vector s vector start end)
4106    (generic-binary-read-vector s vector start end)))
4107
4108(defmethod stream-unread-char ((s concatenated-stream) char)
4109  (let* ((c (concatenated-stream-current-input-stream s)))
4110    (if c
4111      (stream-unread-char c char))))
4112
4113(defmethod stream-listen ((s concatenated-stream))
4114  (do* ((c (concatenated-stream-current-input-stream s)
4115           (concatenated-stream-next-input-stream s)))
4116       ((null c))
4117    (when (stream-listen c)
4118      (return t))))
4119
4120(defmethod stream-eofp ((s concatenated-stream))
4121  (do* ((c (concatenated-stream-current-input-stream s)
4122           (concatenated-stream-next-input-stream s)))
4123       ((null c) t)
4124    (when (stream-listen c)
4125      (return nil))))
4126
4127(defmethod stream-clear-input ((s concatenated-stream))
4128  (let* ((c (concatenated-stream-current-input-stream s)))
4129    (when c (stream-clear-input c))))
4130
4131
4132(defun make-concatenated-stream (&rest streams)
4133  "Return a stream which takes its input from each of the streams in turn,
4134   going on to the next at EOF."
4135  (dolist (s streams (make-instance 'concatenated-stream :streams streams))
4136    (unless (input-stream-p s)
4137      (error "~S is not an input stream" s))))
4138
4139;;;broadcast-streams
4140
4141
4142
4143(defclass broadcast-stream (fundamental-output-stream)
4144    ((streams :initarg :streams :reader broadcast-stream-streams)))
4145
4146(macrolet ((broadcast-method
4147               (op (stream &rest others )
4148                   &optional
4149                   (args (cons stream others)))
4150             (let* ((sub (gensym))
4151                    (result (gensym)))
4152               `(defmethod ,op ((,stream broadcast-stream) ,@others)
4153                 (let* ((,result nil))
4154                   (dolist (,sub (broadcast-stream-streams ,stream) ,result)
4155                             (setq ,result (,op ,@(cons sub (cdr args))))))))))
4156             (broadcast-method stream-write-char (s c))
4157             (broadcast-method stream-write-string
4158                                      (s str &optional (start 0) end)
4159                                      (s str start end))
4160             (broadcast-method stream-write-byte (s b))
4161             (broadcast-method stream-clear-output (s))
4162             (broadcast-method stream-line-column (s))
4163             (broadcast-method stream-set-column (s new))
4164             (broadcast-method stream-advance-to-column (s new))
4165             (broadcast-method stream-start-line-p (s))
4166             (broadcast-method stream-terpri (s))
4167             (broadcast-method stream-force-output (s))
4168             (broadcast-method stream-finish-output (s))
4169             (broadcast-method stream-write-list (s l c))
4170             (broadcast-method stream-write-vector (s v start end)))
4171
4172(defun last-broadcast-stream (s)
4173  (car (last (broadcast-stream-streams s))))
4174
4175(defmethod stream-fresh-line ((s broadcast-stream))
4176  (let* ((did-output-newline nil))
4177    (dolist (sub (broadcast-stream-streams s) did-output-newline)
4178      (setq did-output-newline (stream-fresh-line sub)))))
4179
4180(defmethod stream-element-type ((s broadcast-stream))
4181  (let* ((last (last-broadcast-stream s)))
4182    (if last
4183      (stream-element-type last)
4184      t)))
4185
4186(defmethod stream-length ((s broadcast-stream) &optional new)
4187  (unless new
4188    (let* ((last (last-broadcast-stream s)))
4189      (if last
4190        (stream-length last)
4191        0))))
4192
4193(defmethod stream-position ((s broadcast-stream) &optional new)
4194  (unless new
4195    (let* ((last (last-broadcast-stream s)))
4196      (if last
4197        (stream-position last)
4198        0))))
4199
4200(defun make-broadcast-stream (&rest streams)
4201  (dolist (s streams (make-instance 'broadcast-stream :streams streams))
4202    (unless (output-stream-p s)
4203      (report-bad-arg s '(satisfies output-stream-p)))))
4204
4205
4206
4207;;; String streams.
4208(make-built-in-class 'string-stream 'basic-character-stream)
4209
4210(defmethod print-object ((s string-stream) out)
4211  (print-unreadable-object (s out :type t :identity t)
4212    (unless (open-stream-p s)  (format out " ~s" :closed))))
4213
4214
4215                 
4216
4217(defstruct (string-stream-ioblock (:include ioblock))
4218  string)
4219
4220(defstruct (string-output-stream-ioblock (:include string-stream-ioblock))
4221  (index 0))
4222
4223(defstatic *string-output-stream-class* (make-built-in-class 'string-output-stream 'string-stream 'basic-character-output-stream))
4224
4225(defstatic *fill-pointer-string-output-stream-class* (make-built-in-class 'fill-pointer-string-output-stream 'string-output-stream))
4226
4227(def-standard-initial-binding %string-output-stream-ioblocks% (%cons-pool nil))
4228
4229(defmethod stream-force-output ((s string-output-stream))
4230  nil)
4231
4232(defmethod stream-finish-output ((s string-output-stream))
4233  nil)
4234
4235(defmethod stream-clear-output ((s string-output-stream))
4236  nil)
4237
4238;;; Should only be used for a stream whose class is exactly
4239;;; *string-output-stream-class*
4240(defun %close-string-output-stream (stream ioblock)
4241  (when (eq (basic-stream.class stream)
4242            *string-output-stream-class*)
4243    (without-interrupts
4244     (setf (ioblock-stream ioblock) (pool.data %string-output-stream-ioblocks%)
4245           (pool.data %string-output-stream-ioblocks%) ioblock))))
4246
4247(defun create-string-output-stream-ioblock (&rest keys &key stream &allow-other-keys)
4248  (declare (dynamic-extent keys))
4249  (let* ((recycled (and stream
4250                        (eq (basic-stream.class stream)
4251                            *string-output-stream-class*)
4252                        (without-interrupts
4253                         (let* ((data (pool.data %string-output-stream-ioblocks%)))
4254                           (when data
4255                             (setf (pool.data %string-output-stream-ioblocks%)
4256                                   (ioblock-stream data)
4257                                   (ioblock-stream data) stream
4258                                   (ioblock-device data) -1
4259                                   (ioblock-charpos data) 0
4260                                   (string-output-stream-ioblock-index data) 0))
4261                           data)))))
4262    (or recycled (apply #'make-string-output-stream-ioblock keys))))
4263                       
4264
4265
4266(defun %%make-string-output-stream (class string write-char-function write-string-function)
4267  (let* ((stream (allocate-basic-stream class)))
4268    (initialize-basic-stream stream :element-type 'character)
4269    (let* ((ioblock (create-string-output-stream-ioblock
4270                     :stream stream
4271                     :string string
4272                     :element-type 'character
4273                     :write-char-function write-char-function
4274                     :write-char-when-locked-function write-char-function
4275                     :write-simple-string-function write-string-function
4276                     :force-output-function #'false
4277                     :close-function #'%close-string-output-stream)))
4278      (setf (basic-stream.state stream) ioblock)
4279      stream)))
4280
4281(declaim (inline %string-push-extend))
4282(defun %string-push-extend (char string)
4283  (let* ((fill (%svref string target::vectorH.logsize-cell))
4284         (size (%svref string target::vectorH.physsize-cell)))
4285    (declare (fixnum fill size))
4286    (if (< fill size)
4287      (multiple-value-bind (data offset) (array-data-and-offset string)
4288        (declare (simple-string data) (fixnum offset))
4289        (setf (schar data (the fixnum (+ offset fill))) char
4290              (%svref string target::vectorH.logsize-cell) (the fixnum (1+ fill))))
4291      (vector-push-extend char string))))
4292             
4293
4294(defun fill-pointer-string-output-stream-ioblock-write-char (ioblock char)
4295  ;; can do better (maybe much better) than VECTOR-PUSH-EXTEND here.
4296  (if (eql char #\Newline)
4297    (setf (ioblock-charpos ioblock) 0)
4298    (incf (ioblock-charpos ioblock)))
4299  (%string-push-extend char (string-stream-ioblock-string ioblock)))
4300
4301(defmethod stream-force-output ((stream string-output-stream)) nil)
4302
4303(defun fill-pointer-string-output-stream-ioblock-write-simple-string (ioblock string start-char num-chars)
4304  (let* ((end (+ start-char num-chars))
4305         (nlpos (position #\Newline string :start start-char :end end :from-end t)))
4306    (if nlpos
4307      (setf (ioblock-charpos ioblock) (- end nlpos))
4308      (incf (ioblock-charpos ioblock) num-chars))
4309    (let* ((out (string-stream-ioblock-string ioblock)))
4310      (do* ((n 0 (1+ n))
4311            (i start-char (1+ i)))
4312           ((= n num-chars) num-chars)
4313        (%string-push-extend (schar string i) out)))))
4314
4315(defmethod stream-position ((s fill-pointer-string-output-stream) &optional newpos)
4316  (let* ((string (string-stream-string s)))
4317    (if newpos
4318      (setf (fill-pointer string) newpos)
4319      (fill-pointer string))))
4320
4321;;; If the stream's string is adjustable, it doesn't really have a meaningful
4322;;; "maximum size".
4323(defmethod stream-length ((s string-output-stream) &optional newlen)
4324  (unless newlen
4325    (array-total-size (string-stream-string s))))
4326
4327;;; This creates a FILL-POINTER-STRING-OUTPUT-STREAM.
4328(defun %make-string-output-stream (string)
4329  (unless (and (typep string 'string)
4330               (array-has-fill-pointer-p string))
4331    (error "~S must be a string with a fill pointer."))
4332  (%%make-string-output-stream *fill-pointer-string-output-stream-class* string 'fill-pointer-string-output-stream-ioblock-write-char 'fill-pointer-string-output-stream-ioblock-write-simple-string))
4333
4334(defun string-output-stream-ioblock-write-char (ioblock char)
4335  (let* ((string (string-output-stream-ioblock-string ioblock))
4336         (index (string-output-stream-ioblock-index ioblock))
4337         (len (length string)))
4338    (declare (simple-string string)
4339             (fixnum index len))
4340  (if (eql char #\Newline)
4341    (setf (ioblock-charpos ioblock) 0)
4342    (incf (ioblock-charpos ioblock)))
4343  (if (= index len)
4344      (let* ((newlen (+ len len))      ;non-zero !
4345             (new (make-string newlen)))
4346        (%copy-ivector-to-ivector string 0 new 0 (the fixnum (ash len 2)))
4347        (setq string new)
4348        (setf (string-output-stream-ioblock-string ioblock) new)))
4349    (setf (string-output-stream-ioblock-index ioblock) (the fixnum (1+ index))
4350          (schar string index) char)))
4351
4352(defun string-output-stream-ioblock-write-simple-string (ioblock string start-char num-chars)
4353  (declare (simple-string string)
4354           (fixnum start-char num-chars)
4355           (optimize (speed 3) (safety 0)))
4356  (let* ((out (string-output-stream-ioblock-string ioblock))
4357         (index (string-output-stream-ioblock-index ioblock))
4358         (len (length out))
4359         (need (+ index num-chars)))
4360    (declare (simple-string out)
4361             (fixnum index len need))
4362    (if (< len need)
4363      (let* ((newlen (+ need need))
4364             (new (make-string newlen)))
4365        (declare (fixnum newlen) (simple-string new))
4366        (dotimes (i len)
4367          (setf (schar new i) (schar out i)))
4368        (setq out new)
4369        (setf (string-output-stream-ioblock-string ioblock) new)))
4370    (do* ((src start-char (1+ src))
4371          (dest index (1+ dest))
4372          (nlpos nil)
4373          (end (+ start-char num-chars)))
4374         ((= src end)
4375          (setf (string-output-stream-ioblock-index ioblock) need)
4376          (if nlpos
4377            (setf (ioblock-charpos ioblock) (the fixnum (- end (the fixnum nlpos))))
4378            (incf (ioblock-charpos ioblock) num-chars))
4379          num-chars)
4380      (declare (fixnum src dest end))
4381      (let* ((char (schar string src)))
4382        (if (eql char #\Newline)
4383          (setq nlpos (the fixnum (1+ src))))
4384        (setf (schar out dest) char)))))
4385
4386
4387(defmethod stream-position ((stream string-output-stream) &optional newpos)
4388  (let* ((ioblock (basic-stream-ioblock stream)))
4389    (if (null newpos)
4390      (string-output-stream-ioblock-index ioblock)
4391      (if (and (typep newpos 'fixnum)
4392               (>= (the fixnum newpos) 0)
4393               (<= (the fixnum newpos) (length (string-output-stream-ioblock-string ioblock))))
4394        (setf (string-output-stream-ioblock-index ioblock) newpos)))))
4395
4396(defun make-simple-string-output-stream ()
4397  (%%make-string-output-stream *string-output-stream-class*
4398                               (make-string 40)
4399                               'string-output-stream-ioblock-write-char
4400                               'string-output-stream-ioblock-write-simple-string))
4401
4402(defun make-string-output-stream (&key (element-type 'character element-type-p))
4403  "Return an output stream which will accumulate all output given it for
4404   the benefit of the function GET-OUTPUT-STREAM-STRING."
4405  (when (and element-type-p
4406             (not (member element-type '(base-character character
4407                                         standard-char))))
4408    (unless (subtypep element-type 'character)
4409      (error "~S argument ~S is not a subtype of ~S."
4410             :element-type element-type 'character)))
4411  (make-simple-string-output-stream))
4412
4413
4414;;;"Bounded" string output streams.
4415(defstatic *truncating-string-output-stream-class* (make-built-in-class 'truncating-string-stream 'string-output-stream))
4416
4417(defun truncating-string-output-stream-ioblock-write-char (ioblock char)
4418  (let* ((stream (ioblock-stream ioblock))
4419         (string (string-output-stream-ioblock-string ioblock))
4420         (index (string-output-stream-ioblock-index ioblock)))
4421    (declare (fixnum index) (simple-string string))
4422    (if (< index (the fixnum (length string)))
4423      (progn
4424        (setf (schar string index) char
4425              (string-output-stream-ioblock-index ioblock) (the fixnum (1+ index)))
4426        (if (eql char #\Newline)
4427          (setf (ioblock-charpos ioblock) 0)
4428          (incf (ioblock-charpos ioblock))))
4429      (setf (getf (basic-stream.info stream) :truncated) t))))
4430
4431(defun truncating-string-output-stream-ioblock-write-simple-string