source: branches/working-0711/ccl/level-1/l1-streams.lisp @ 12944

Last change on this file since 12944 was 12944, checked in by gz, 10 years ago

make read-toplevel-form call read-recording-source, take keyword args to pass into it (r12663)

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