source: release/1.2/source/level-1/l1-streams.lisp @ 9730

Last change on this file since 9730 was 9730, checked in by gb, 11 years ago

Remove duplicate STREAM-READ-VECTOR (BINARY-INPUT-STREAM T T T) method.

In the remaining STREAM-READ-VECTOR method (and in STREAM-READ-LIST
on BINARY-INPUT-STREAM), call READ-BYTE with eof-value of :EOF (as noted
by Wade Humeniuk.)

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