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

Last change on this file since 11101 was 11101, checked in by gz, 13 years ago

Another round of changes from the trunk, mostly just mods in internal mechanisms in support of various recent ports.

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