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

Last change on this file since 15536 was 15536, checked in by gb, 7 years ago

Support using the "coding" option in a file's file options line (a
line at the start of a text file that contains name:value pairs
separated by semicolons bracketed by -*- sequences) to determine a
file's character encoding. Specifically:

  • OPEN now allows an external-format of :INFERRED; previously, this was shorthand for an external-format whose line-termination was inferred and whose character encoding was based on *DEFAULT-FILE-CHARACTER-ENCODING*. When an input file whose external-format is specified as :INFERRED is opened, its file options are parsed and the value of the "coding" option is used if such an option is found (and if the value is something that CCL supports.) If a supported "coding" option isn't found, *DEFAULT-FILE-CHARACTER-ENCODING* is used as before.
  • In the Cocoa IDE, the Hemlock command "Ensure File Options Line" (bound to Control-Meta-M by default) ensures that the first line in the current buffer is a file options line and fills in some plausible values for the "Mode", "Package", and "Coding" options. The "Process File Options" command (Control-Meta-m) can be used to process the file options line after it's been edited. (The file options line is always processed when the file is first opened; changes to the "coding" option affect how the file will be saved.)

When a Lisp source file is opened in the IDE editor, the following
character encodings are tried in this order until one of them
succeeds:

  • if the "Open ..." panel was used to open the file and an encoding other than "Automatic" - which is now the default - is selected, that encoding is tried.
  • if a "coding" option is found, that encoding is tried.
  • the value of *DEFAULT-FILE-CHARACTER-ENCODING* is tried.
  • iso-8859-1 is tried. All files can be decoded in iso-8859-1.

This is all supposed to be what Emacs does and I think that it's
pretty close in practice.

A file that caused problems for Paul Krueger a few days ago
because its encoding (ISO-8859-1) wasn't guessed correctly
now has an explicit "coding" option and serves as a test case.

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