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

Last change on this file since 13065 was 13065, checked in by rme, 10 years ago

In MAKE-HEAP-IVECTOR, ensure that element-count is not too big.
(fixes ticket:611)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 230.3 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   Portions copyright (C) 2001 Clozure Associates
5;;;   This file is part of OpenMCL. 
6;;;
7;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with OpenMCL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18(in-package "CCL")
19
20;;;
21
22(defclass stream ()
23  ())
24
25
26(defclass input-stream (stream)
27  ())
28
29
30(defclass output-stream (stream) ())
31
32(defmethod stream-direction ((s stream))
33  )
34
35(defmethod stream-domain ((s stream))
36  t)
37
38
39(defmethod stream-direction ((s input-stream))
40  (if (typep s 'output-stream)
41    :io
42    :input))
43
44(defmethod stream-direction ((s output-stream))
45  (if (typep s 'input-stream)
46    :io
47    :output))
48
49(defun check-io-timeout (timeout)
50  (when timeout
51    (require-type timeout '(real 0 1000000))))
52
53(defmethod stream-input-timeout ((s input-stream))
54  nil)
55
56(defmethod (setf input-stream-timeout) (new (s input-stream))
57  (check-io-timeout new))
58
59(defmethod stream-output-timeout ((s output-stream))
60  nil)
61
62(defmethod (setf stream-output-timeout) (new (s output-stream))
63  (check-io-timeout new))
64
65;;; Try to return a string containing characters that're near the
66;;; stream's current position, if that makes sense.  Return NIL
67;;; if it doesn't make sense.
68;;; Some things (SOCKET-ERRORs) are signaled as STREAM-ERRORs
69;;; whose STREAM args aren't streams.  That's wrong, but
70;;; defining this method on T keeps things from blowing up worse.
71(defmethod stream-surrounding-characters ((s t))
72  (declare (ignore s))
73  nil)
74
75
76;;; The "direction" argument only helps us dispatch on two-way streams:
77;;; it's legal to ask for the :output device of a stream that's only open
78;;; for input, and one might get a non-null answer in that case.
79(defmethod stream-device ((s stream) direction)
80  (declare (ignore direction)))
81
82;;; Some generic stream functions:
83(defmethod stream-length ((x t) &optional new)
84  (declare (ignore new))
85  (report-bad-arg x 'stream))
86
87(defmethod stream-position ((x t) &optional new)
88  (declare (ignore new))
89  (report-bad-arg x 'stream))
90
91(defmethod stream-element-type ((x t))
92  (report-bad-arg x 'stream))
93
94(defmethod stream-force-output ((x t))
95  (report-bad-arg x 'stream))
96
97(defmethod stream-position ((s stream) &optional newpos)
98  (declare (ignore newpos)))
99
100;;; For input streams:
101
102;; From Shannon Spires, slightly modified.
103(defun generic-read-line (s)
104  (let* ((str (make-array 20 :element-type 'base-char
105                          :adjustable t :fill-pointer 0))
106         (eof nil))
107    (do* ((ch (read-char s nil :eof) (read-char s nil :eof)))
108         ((or (eq ch #\newline) (setq eof (eq ch :eof)))
109          (values (ensure-simple-string str) eof))
110      (vector-push-extend ch str))))
111
112(defun generic-character-read-list (stream list count)
113  (declare (fixnum count))
114  (do* ((tail list (cdr tail))
115        (i 0 (1+ i)))
116       ((= i count) count)
117    (declare (fixnum i))
118    (let* ((ch (read-char stream nil :eof)))
119      (if (eq ch :eof)
120        (return i)
121        (rplaca tail ch)))))
122
123(defun generic-binary-read-list (stream list count)
124  (declare (fixnum count))
125  (do* ((tail list (cdr tail))
126        (i 0 (1+ i)))
127       ((= i count) count)
128    (declare (fixnum i))
129    (let* ((ch (stream-read-byte stream)))
130      (if (eq ch :eof)
131        (return i)
132        (rplaca tail ch)))))
133
134(defun generic-character-read-vector (stream vector start end)
135  (declare (fixnum start end))
136  (do* ((i start (1+ i)))
137       ((= i end) end)
138    (declare (fixnum i))
139    (let* ((ch (stream-read-char stream)))
140      (if (eq ch :eof)
141        (return i)
142        (setf (uvref vector i) ch)))))
143
144(defun generic-binary-read-vector (stream vector start end)
145  (declare (fixnum start end))
146  (do* ((i start (1+ i)))
147       ((= i end) end)
148    (declare (fixnum i))
149    (let* ((byte (stream-read-byte stream)))
150      (if (eq byte :eof)
151        (return i)
152        (setf (uvref vector i) byte)))))
153
154
155;;; For output streams:
156
157(defun generic-advance-to-column (s col)
158  (let* ((current (column s)))
159    (unless (null current)
160      (when (< current col)
161        (do* ((i current (1+ i)))
162             ((= i col))
163          (write-char #\Space s)))
164      t)))
165
166
167
168(defun generic-stream-write-string (stream string start end)
169  (setq end (check-sequence-bounds string start end))
170  (locally (declare (fixnum start end))
171    (multiple-value-bind (vect offset) (array-data-and-offset string)
172      (declare (fixnum offset))
173      (unless (zerop offset)
174        (incf start offset)
175        (incf end offset))
176      (do* ((i start (1+ i)))
177           ((= i end) string)
178        (declare (fixnum i))
179        (write-char (schar vect i) stream)))))
180
181
182
183
184
185
186
187
188
189
190
191
192(defstatic *heap-ivectors* ())
193(defvar *heap-ivector-lock* (make-lock))
194
195
196
197(defun %make-heap-ivector (subtype size-in-bytes size-in-elts)
198  (with-macptrs ((ptr (malloc (+ size-in-bytes
199                                 #+32-bit-target (+ 4 2 7) ; 4 for header, 2 for delta, 7 for round up
200                                 #+64-bit-target (+ 8 2 15) ; 8 for header, 2 for delta, 15 for round up
201                                 ))))
202    (let ((vect (fudge-heap-pointer ptr subtype size-in-elts))
203          (p (%null-ptr)))
204      (%vect-data-to-macptr vect p)
205      (with-lock-grabbed (*heap-ivector-lock*)
206        (push vect *heap-ivectors*))
207      (values vect p))))
208
209(defun %heap-ivector-p (v)
210  (with-lock-grabbed (*heap-ivector-lock*)
211    (not (null (member v *heap-ivectors* :test #'eq)))))
212
213
214(defun dispose-heap-ivector (v)
215  (if (%heap-ivector-p v)
216    (with-macptrs (p)
217      (with-lock-grabbed (*heap-ivector-lock*)
218        (setq *heap-ivectors* (delq v *heap-ivectors*)))
219      (%%make-disposable p v)
220      (free p))))
221
222(defun %dispose-heap-ivector (v)
223  (dispose-heap-ivector v))
224
225(defun make-heap-ivector (element-count element-type)
226  (require-type element-count `(unsigned-byte ,(- target::nbits-in-word
227                                                  target::num-subtag-bits)))
228  (let* ((subtag (ccl::element-type-subtype element-type)))
229    (unless
230        #+ppc32-target
231        (= (logand subtag ppc32::fulltagmask)
232               ppc32::fulltag-immheader)
233        #+ppc64-target
234        (= (logand subtag ppc64::lowtagmask)
235           ppc64::lowtag-immheader)
236        #+x8632-target
237        (= (logand subtag x8632::fulltagmask)
238           x8632::fulltag-immheader)
239        #+x8664-target
240        (logbitp (the (mod 16) (logand subtag x8664::fulltagmask))
241                 (logior (ash 1 x8664::fulltag-immheader-0)
242                         (ash 1 x8664::fulltag-immheader-1)
243                         (ash 1 x8664::fulltag-immheader-2)))
244      (error "~s is not an ivector subtype." element-type))
245    (let* ((size-in-octets (ccl::subtag-bytes subtag element-count)))
246      (multiple-value-bind (pointer vector)
247          (ccl::%make-heap-ivector subtag size-in-octets element-count)
248        (values pointer vector size-in-octets)))))
249
250
251
252
253
254
255
256
257
258(defvar *elements-per-buffer* 2048)  ; default buffer size for file io
259
260(defmethod streamp ((x t))
261  nil)
262
263(defmethod streamp ((x stream))
264  t)
265
266(defmethod stream-io-error ((stream stream) error-number context)
267  (error 'simple-stream-error :stream stream
268         :format-control (format nil "~a during ~a"
269                                 (%strerror error-number) context)))
270
271
272
273(defmethod stream-write-char ((stream stream) char)
274  (declare (ignore char))
275  (error "stream ~S is not capable of output" stream))
276
277(defun stream-write-entire-string (stream string)
278  (stream-write-string stream string))
279
280
281(defmethod stream-read-char ((x t))
282  (report-bad-arg x 'stream))
283
284(defmethod stream-read-char ((stream stream))
285  (error "~s is not capable of input" stream))
286
287(defmethod stream-unread-char ((x t) char)
288  (declare (ignore char))
289  (report-bad-arg x 'stream))
290
291(defmethod stream-unread-char ((stream stream) char)
292  (declare (ignore char))
293  (error "stream ~S is not capable of input" stream))
294
295
296
297(defmethod stream-force-output ((stream output-stream)) nil)
298(defmethod stream-maybe-force-output ((stream stream))
299  (stream-force-output stream))
300
301(defmethod stream-finish-output ((stream output-stream)) nil)
302
303
304
305(defmethod stream-clear-output ((stream output-stream)) nil)
306
307(defmethod close ((stream stream) &key abort)
308  (declare (ignore abort))
309  (open-stream-p stream))
310
311(defmethod close-for-termination ((stream stream) abort)
312  (close stream :abort abort))
313
314
315(defmethod open-stream-p ((x t))
316  (report-bad-arg x 'stream))
317
318(defmethod open-stream-p ((stream stream))
319  t)
320
321(defmethod stream-external-format ((x t))
322  (report-bad-arg x 'stream))
323
324(defmethod stream-external-format ((s stream))
325  nil)
326
327
328(defmethod (setf stream-external-format) (new (s t))
329  (normalize-external-format (stream-domain s) new)
330  (report-bad-arg s 'stream))
331
332
333
334   
335(defmethod stream-fresh-line ((stream output-stream))
336  (terpri stream)
337  t)
338
339(defmethod stream-line-length ((stream stream))
340  "This is meant to be shadowed by particular kinds of streams,
341   esp those associated with windows."
342  80)
343
344(defmethod interactive-stream-p ((x t))
345  (report-bad-arg x 'stream))
346
347(defmethod interactive-stream-p ((stream stream)) nil)
348
349(defmethod stream-clear-input ((x t))
350  (report-bad-arg x 'input-stream))
351
352(defmethod stream-clear-input ((stream input-stream)) nil)
353
354(defmethod stream-listen ((stream input-stream))
355  (not (eofp stream)))
356
357(defmethod stream-filename ((stream stream))
358  (report-bad-arg stream 'file-stream))
359
360
361
362
363;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
364
365;;; For input streams, the IO-BUFFER-COUNT field denotes the number
366;;; of elements read from the underlying input source (e.g., the
367;;; file system.)  For output streams, it's the high-water mark of
368;;; elements output to the buffer.
369
370(defstruct io-buffer
371               ;; This type is too complex during bootstrapping.
372  (buffer nil #|:type (or (simple-array * (*)) null)|#)
373  (bufptr nil :type (or macptr null))
374  (size 0 :type fixnum)                 ; size (in octets) of buffer
375  (idx 0 :type fixnum)                  ; index of next element
376  (count 0 :type fixnum)                ; count of active elements
377  (limit 0 :type fixnum)                ; size (in elements) of buffer
378  (translate nil)                       ; newline-translation
379  )
380
381(defmethod print-object ((buf io-buffer) out)
382  (print-unreadable-object (buf out :identity t :type t)
383    (let* ((buffer (io-buffer-buffer buf)))
384      (when buffer (format out " ~s " (array-element-type buffer))))
385    (format out "~d/~d/~d"
386            (io-buffer-idx buf)
387            (io-buffer-count buf)
388            (io-buffer-limit buf))))
389
390(defstruct ioblock
391  stream                                ; the stream being buffered
392  untyi-char                            ; nil or last value passed to
393                                        ;  stream-unread-char
394  (inbuf nil :type (or null io-buffer))
395  (outbuf nil :type (or null io-buffer))
396  (element-type 'character)
397  (element-shift 0 :type fixnum)        ;element shift count
398  (charpos 0 :type (or null fixnum))     ;position of cursor
399  (device -1 :type (or null fixnum))     ;file descriptor
400  (advance-function 'ioblock-advance)
401  (listen-function 'ioblock-listen)
402  (eofp-function 'ioblock-eofp)
403  (force-output-function 'ioblock-force-output)
404  (close-function 'ioblock-close)
405  (inbuf-lock nil)
406  (eof nil)
407  (interactive nil)
408  (dirty nil)
409  (outbuf-lock nil)
410  (owner nil)
411  (read-char-function 'ioblock-no-char-input)
412  (read-byte-function 'ioblock-no-binary-input)
413  (write-byte-function 'ioblock-no-binary-output)
414  (write-char-function 'ioblock-no-char-output)
415  (encoding nil)
416  (pending-byte-order-mark nil)
417  (decode-literal-code-unit-limit 256)
418  (encode-output-function nil)
419  (decode-input-function nil)
420  (read-char-when-locked-function 'ioblock-no-char-input)
421  (write-simple-string-function 'ioblock-no-char-output)
422  (character-read-vector-function 'ioblock-no-char-input)
423  (read-line-function 'ioblock-no-char-input)
424  (write-char-when-locked-function 'ioblock-no-char-output)
425  (read-byte-when-locked-function 'ioblock-no-binary-input)
426  (write-byte-when-locked-function 'ioblock-no-binary-output)
427  (peek-char-function 'ioblock-no-char-input)
428  (native-byte-order t)
429  (read-char-without-translation-when-locked-function 'ioblock-no-char-input)
430  (write-char-without-translation-when-locked-function 'iblock-no-char-output)
431  (sharing nil)
432  (line-termination nil)
433  (unread-char-function 'ioblock-no-char-input)
434  (encode-literal-char-code-limit 256)
435  (input-timeout nil)
436  (output-timeout nil)
437  (deadline nil))
438
439
440;;; Functions on ioblocks.  So far, we aren't saying anything
441;;; about how streams use them.
442
443(defun ioblock-no-binary-input (ioblock &rest otters)
444  (declare (ignore otters))
445  (report-bad-arg (ioblock-stream ioblock) '(and binary-stream input-stream)))
446
447(defun ioblock-no-binary-output (ioblock &rest others)
448  (declare (ignore others))
449  (report-bad-arg (ioblock-stream ioblock) '(and binary-stream output-stream)))
450
451(defun ioblock-no-char-input (ioblock &rest others)
452  (declare (ignore others))
453  (report-bad-arg (ioblock-stream ioblock) '(and character-stream input-stream)))
454
455(defun ioblock-no-char-output (ioblock &rest others)
456  (declare (ignore others))
457  (report-bad-arg (ioblock-stream ioblock) '(and character-stream output-stream)))
458
459
460(defun ioblock-octets-to-elements (ioblock octets)
461  (let* ((shift (ioblock-element-shift ioblock)))
462    (declare (fixnum shift))
463    (if (zerop shift)
464      octets
465      (ash octets (- shift)))))
466
467(defun ioblock-elements-to-octets (ioblock elements)
468  (let* ((shift (ioblock-element-shift ioblock)))
469    (declare (fixnum shift))
470    (if (zerop shift)
471      elements
472      (ash elements shift))))
473
474
475
476;;; ioblock must really be an ioblock or you will crash
477;;; Also: the expression "ioblock" is evaluated multiple times.
478
479(declaim (inline check-ioblock-owner))
480(defun check-ioblock-owner (ioblock)
481  (declare (optimize (speed 3)))
482  (let* ((owner (ioblock-owner ioblock)))
483    (if owner
484      (or (eq owner *current-process*)
485          (conditional-store (ioblock-owner ioblock) 0 *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 (* 10 size)) 0))
509                 (end (min (+ idx (* 10 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-string 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-string 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-string 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-string 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-string 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))
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;;; Thread must own ioblock lock(s).
2490(defun %%ioblock-close (ioblock)
2491  (when (ioblock-device ioblock)
2492    (let* ((stream (ioblock-stream ioblock)))
2493      (funcall (ioblock-close-function ioblock) stream ioblock)
2494      (setf (ioblock-device ioblock) nil)
2495      (setf (stream-ioblock stream) nil)
2496      (let* ((in-iobuf (ioblock-inbuf ioblock))
2497             (out-iobuf (ioblock-outbuf ioblock))
2498             (in-buffer (if in-iobuf (io-buffer-buffer in-iobuf)))
2499             (in-bufptr (if in-iobuf (io-buffer-bufptr in-iobuf)))
2500             (out-buffer (if out-iobuf (io-buffer-buffer out-iobuf)))
2501             (out-bufptr (if out-iobuf (io-buffer-bufptr out-iobuf))))
2502        (if (and in-buffer in-bufptr)
2503          (%dispose-heap-ivector in-buffer))
2504        (unless (eq in-buffer out-buffer)
2505          (if (and out-buffer out-bufptr)
2506            (%dispose-heap-ivector out-buffer)))
2507        (when in-iobuf
2508          (setf (io-buffer-buffer in-iobuf) nil
2509                (io-buffer-bufptr in-iobuf) nil
2510                (ioblock-inbuf ioblock) nil))
2511        (when out-iobuf
2512          (setf (io-buffer-buffer out-iobuf) nil
2513                (io-buffer-bufptr out-iobuf) nil
2514                (ioblock-outbuf ioblock) nil))
2515        t))))
2516
2517(defun %ioblock-close (ioblock)
2518  (let* ((in-lock (ioblock-inbuf-lock ioblock))
2519         (out-lock (ioblock-outbuf-lock ioblock)))
2520    (if in-lock
2521      (with-lock-grabbed (in-lock)
2522        (if (and out-lock (not (eq out-lock in-lock)))
2523          (with-lock-grabbed (out-lock)
2524            (%%ioblock-close ioblock))
2525          (%%ioblock-close ioblock)))
2526      (if out-lock
2527        (with-lock-grabbed (out-lock)
2528          (%%ioblock-close ioblock))
2529        (progn
2530          (check-ioblock-owner ioblock)
2531          (%%ioblock-close ioblock))))))
2532
2533
2534;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2535
2536;;; Character-at-a-time line-termination-translation functions.
2537;;; It's not always possible to just blast through the buffer, blindly
2538;;; replacing #xd with #xa (for example), and it's not always desirable
2539;;; to do that (if we support changing encoding on open streams.)
2540;;; This is done at a fairly high level; some cases could be done at
2541;;; a lower level, and some cases are hard even at that lower level.
2542;;; This approach doesn't slow down the simple case (when no line-termination
2543;;; translation is used), and hopefully isn't -that- bad.
2544
2545(declaim (inline %ioblock-read-char-translating-cr-to-newline))
2546(defun %ioblock-read-char-translating-cr-to-newline (ioblock)
2547  (let* ((ch (funcall
2548              (ioblock-read-char-without-translation-when-locked-function
2549               ioblock)
2550              ioblock)))
2551    (if (eql ch #\Return)
2552      #\Newline
2553      ch)))
2554
2555(defun %private-ioblock-read-char-translating-cr-to-newline (ioblock)
2556  (check-ioblock-owner ioblock)
2557  (%ioblock-read-char-translating-cr-to-newline ioblock))
2558
2559(defun %locked-ioblock-read-char-translating-cr-to-newline (ioblock)
2560  (with-ioblock-input-lock-grabbed (ioblock)
2561    (%ioblock-read-char-translating-cr-to-newline ioblock)))
2562
2563(declaim (inline %ioblock-read-char-translating-crlf-to-newline))
2564(defun %ioblock-read-char-translating-crlf-to-newline (ioblock)
2565  (let* ((ch (funcall
2566              (ioblock-read-char-without-translation-when-locked-function
2567               ioblock)
2568              ioblock)))
2569    (if (eql ch #\Return)
2570      (let* ((next (funcall
2571                    (ioblock-read-char-without-translation-when-locked-function
2572                     ioblock)
2573                    ioblock)))
2574        (if (eql next #\Linefeed)
2575          next
2576          (progn
2577            (unless (eq next :eof)
2578              (setf (ioblock-untyi-char ioblock) next))
2579            ch)))
2580      ch)))
2581   
2582(defun %private-ioblock-read-char-translating-crlf-to-newline (ioblock)
2583  (check-ioblock-owner ioblock)
2584  (%ioblock-read-char-translating-crlf-to-newline ioblock))
2585
2586(defun %locked-ioblock-read-char-translating-crlf-to-newline (ioblock)
2587  (with-ioblock-input-lock-grabbed (ioblock)
2588    (%ioblock-read-char-translating-crlf-to-newline ioblock)))
2589
2590(declaim (inline %ioblock-read-char-translating-line-separator-to-newline))
2591(defun %ioblock-read-char-translating-line-separator-to-newline (ioblock)
2592  (let* ((ch (funcall
2593              (ioblock-read-char-without-translation-when-locked-function
2594               ioblock)
2595              ioblock)))
2596    (if (eql ch #\Line_Separator)
2597      #\Newline
2598      ch)))
2599
2600(defun %private-ioblock-read-char-translating-line-separator-to-newline (ioblock)
2601  (check-ioblock-owner ioblock)
2602  (%ioblock-read-char-translating-line-separator-to-newline ioblock))
2603
2604(defun %locked-ioblock-read-char-translating-line-separator-to-newline (ioblock)
2605  (with-ioblock-input-lock-grabbed (ioblock)
2606    (%ioblock-read-char-translating-line-separator-to-newline ioblock)))
2607
2608(declaim (inline %ioblock-write-char-translating-newline-to-cr))
2609(defun %ioblock-write-char-translating-newline-to-cr (ioblock char)
2610  (funcall (ioblock-write-char-without-translation-when-locked-function
2611            ioblock)
2612           ioblock
2613           (if (eql char #\Newline) #\Return char)))
2614
2615(defun %private-ioblock-write-char-translating-newline-to-cr (ioblock char)
2616  (check-ioblock-owner ioblock)
2617  (%ioblock-write-char-translating-newline-to-cr ioblock char))
2618
2619(defun %locked-ioblock-write-char-translating-newline-to-cr (ioblock char)
2620  (with-ioblock-output-lock-grabbed (ioblock)
2621    (%ioblock-write-char-translating-newline-to-cr ioblock char)))
2622
2623(declaim (inline %ioblock-write-char-translating-newline-to-crlf))
2624(defun %ioblock-write-char-translating-newline-to-crlf (ioblock char)
2625  (when (eql char #\Newline)
2626    (funcall (ioblock-write-char-without-translation-when-locked-function
2627              ioblock)
2628             ioblock
2629             #\Return))   
2630  (funcall (ioblock-write-char-without-translation-when-locked-function
2631            ioblock)
2632           ioblock
2633           char))
2634
2635(defun %private-ioblock-write-char-translating-newline-to-crlf (ioblock char)
2636  (check-ioblock-owner ioblock)
2637  (%ioblock-write-char-translating-newline-to-crlf ioblock char))
2638
2639(defun %locked-ioblock-write-char-translating-newline-to-crlf (ioblock char)
2640  (with-ioblock-output-lock-grabbed (ioblock)
2641    (%ioblock-write-char-translating-newline-to-crlf ioblock char)))
2642
2643(declaim (inline %ioblock-write-char-translating-newline-to-line-separator))
2644(defun %ioblock-write-char-translating-newline-to-line-separator (ioblock char)
2645  (funcall (ioblock-write-char-without-translation-when-locked-function
2646            ioblock)
2647           ioblock
2648           (if (eql char #\Newline) #\Line_Separator char)))
2649
2650(defun %private-ioblock-write-char-translating-newline-to-line-separator (ioblock char)
2651  (check-ioblock-owner ioblock)
2652  (%ioblock-write-char-translating-newline-to-line-separator ioblock char))
2653
2654(defun %locked-ioblock-write-char-translating-newline-to-line-separator (ioblock char)
2655  (with-ioblock-output-lock-grabbed (ioblock)
2656    (%ioblock-write-char-translating-newline-to-line-separator ioblock char)))
2657
2658;;; If we do newline translation, we probably can't be too clever about reading/writing
2659;;; strings.
2660(defun %ioblock-write-simple-string-with-newline-translation (ioblock string start-pos num-chars)
2661  (declare (fixnum start-pos num-chars) (simple-string string))
2662  (let* ((col (ioblock-charpos ioblock))
2663         (wcf (ioblock-write-char-when-locked-function ioblock)))
2664    (declare (fixnum col))
2665    (do* ((i start-pos (1+ i))
2666          (n 0 (1+ n)))
2667         ((= n num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
2668      (let* ((char (schar string i)))
2669        (if (eql char #\Newline)
2670          (setq col 0)
2671          (incf col))
2672        (funcall wcf ioblock char)))))
2673
2674
2675;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2676
2677(defun setup-ioblock-input (ioblock character-p element-type sharing encoding line-termination)
2678  (setf (ioblock-sharing ioblock) sharing)
2679  (when character-p
2680    (setf (ioblock-unread-char-function ioblock) (select-stream-untyi-function (ioblock-stream ioblock) :input))
2681    (setf (ioblock-decode-literal-code-unit-limit ioblock)
2682          (if encoding
2683            (character-encoding-decode-literal-code-unit-limit encoding)
2684            256))   
2685    (if encoding
2686      (let* ((unit-size (character-encoding-code-unit-size encoding)))
2687        (setf (ioblock-peek-char-function ioblock) '%encoded-ioblock-peek-char)
2688        (setf (ioblock-read-line-function ioblock)
2689              '%ioblock-encoded-read-line)
2690        (setf (ioblock-character-read-vector-function ioblock)
2691              '%ioblock-encoded-character-read-vector)       
2692        (setf (ioblock-decode-input-function ioblock)
2693              (character-encoding-stream-decode-function encoding))
2694        (setf (ioblock-read-char-function ioblock)
2695              (ecase unit-size
2696                (8
2697                 (setf (ioblock-read-char-when-locked-function ioblock)
2698                       '%ioblock-read-u8-encoded-char)
2699                 (case sharing
2700                   (:private '%private-ioblock-read-u8-encoded-char)
2701                   (:lock '%locked-ioblock-read-u8-encoded-char)
2702                   (t '%ioblock-read-u8-encoded-char)))
2703                (16
2704                 (if (character-encoding-native-endianness encoding)
2705                   (progn
2706                    (setf (ioblock-read-char-when-locked-function ioblock)
2707                          '%ioblock-read-u16-encoded-char)
2708                    (case sharing
2709                      (:private '%private-ioblock-read-u16-encoded-char)
2710                      (:lock '%locked-ioblock-read-u16-encoded-char)
2711                      (t '%ioblock-read-u16-encoded-char)))
2712                   (progn
2713                     (setf (ioblock-read-char-when-locked-function ioblock)
2714                           '%ioblock-read-swapped-u16-encoded-char)
2715                    (case sharing
2716                      (:private '%private-ioblock-read-swapped-u16-encoded-char)
2717                      (:lock '%locked-ioblock-read-swapped-u16-encoded-char)
2718                      (t '%ioblock-read-swapped-u16-encoded-char)))))
2719                (32
2720                 (if (character-encoding-native-endianness encoding)
2721                   (progn
2722                    (setf (ioblock-read-char-when-locked-function ioblock)
2723                          #'%ioblock-read-u32-encoded-char)
2724                    (case sharing
2725                      (:private #'%private-ioblock-read-u32-encoded-char)
2726                      (:lock #'%locked-ioblock-read-u32-encoded-char)
2727                      (t #'%ioblock-read-u32-encoded-char)))
2728                   (progn
2729                     (setf (ioblock-read-char-when-locked-function ioblock)
2730                           #'%ioblock-read-swapped-u32-encoded-char)
2731                    (case sharing
2732                      (:private '#'%private-ioblock-read-swapped-u16-encoded-char)
2733                      (:lock #'%locked-ioblock-read-swapped-u32-encoded-char)
2734                      (t #'%ioblock-read-swapped-u32-encoded-char))))))))
2735      (progn
2736        (setf (ioblock-peek-char-function ioblock) '%ioblock-peek-char)
2737        (setf (ioblock-read-char-function ioblock)
2738              (case sharing
2739                (:private '%private-ioblock-tyi)
2740                (:lock '%locked-ioblock-tyi)
2741                (t '%ioblock-tyi)))
2742        (setf (ioblock-read-char-when-locked-function ioblock)
2743              '%ioblock-tyi)
2744        (setf (ioblock-character-read-vector-function ioblock)
2745              '%ioblock-unencoded-character-read-vector)
2746        (setf (ioblock-read-line-function ioblock)
2747              '%ioblock-unencoded-read-line)))
2748    (when line-termination
2749      (install-ioblock-input-line-termination ioblock line-termination))
2750    )
2751
2752  (unless (or (eq element-type 'character)
2753              (subtypep element-type 'character))
2754    (let* ((subtag (element-type-subtype element-type)))
2755      (declare (type (unsigned-byte 8) subtag))
2756      (setf (ioblock-read-byte-function ioblock)
2757            (cond ((= subtag target::subtag-u8-vector)
2758                   (if character-p
2759                     ;; The bivalent case, at least for now
2760                     (progn
2761                       (setf (ioblock-read-byte-when-locked-function ioblock)
2762                             '%bivalent-ioblock-read-u8-byte)
2763                       (case sharing
2764                         (:private '%bivalent-private-ioblock-read-u8-byte)
2765                         (:lock '%bivalent-locked-ioblock-read-u8-byte)
2766                         (t '%bivalent-ioblock-read-u8-byte)))
2767                     (progn
2768                       (setf (ioblock-read-byte-when-locked-function ioblock)
2769                             '%ioblock-read-u8-byte)
2770                       (case sharing
2771                         (:private '%private-ioblock-read-u8-byte)
2772                         (:lock '%locked-ioblock-read-u8-byte)
2773                         (t '%ioblock-read-u8-byte)))))
2774                  ((= subtag target::subtag-s8-vector)
2775                   (setf (ioblock-read-byte-when-locked-function ioblock)
2776                         '%ioblock-read-s8-byte) 
2777                   (case sharing
2778                     (:private '%private-ioblock-read-s8-byte)
2779                     (:lock '%locked-ioblock-read-s8-byte)
2780                     (t '%ioblock-read-s8-byte)))
2781                  ((= subtag target::subtag-u16-vector)
2782                   (setf (ioblock-read-byte-when-locked-function ioblock)
2783                         '%ioblock-read-u16-byte)
2784                   (case sharing
2785                     (:private '%private-ioblock-read-u16-byte)
2786                     (:lock '%locked-ioblock-read-u16-byte)
2787                     (t '%ioblock-read-u16-byte)))
2788                  ((= subtag target::subtag-s16-vector)
2789                   (setf (ioblock-read-byte-when-locked-function ioblock)
2790                         '%ioblock-read-s16-byte)
2791                   (case sharing
2792                     (:private '%private-ioblock-read-s16-byte)
2793                     (:lock '%locked-ioblock-read-s16-byte)
2794                     (t '%ioblock-read-s16-byte)))
2795                  ((= subtag target::subtag-u32-vector)
2796                   (setf (ioblock-read-byte-when-locked-function ioblock)
2797                         '%ioblock-read-u32-byte)
2798                   (case sharing
2799                     (:private '%private-ioblock-read-u32-byte)
2800                     (:lock '%locked-ioblock-read-u32-byte)
2801                     (t '%ioblock-read-u32-byte)))
2802                  ((= subtag target::subtag-s32-vector)
2803                   (setf (ioblock-read-byte-when-locked-function ioblock)
2804                         '%ioblock-read-s32-byte)                   
2805                   (case sharing
2806                     (:private '%private-ioblock-read-s32-byte)
2807                     (:lock '%locked-ioblock-read-s32-byte)
2808                     (t '%ioblock-read-s32-byte)))
2809                  #+64-bit-target
2810                  ((= subtag target::subtag-u64-vector)
2811                   (setf (ioblock-read-byte-when-locked-function ioblock)
2812                         '%ioblock-read-u64-byte)                   
2813                   (case sharing
2814                     (:private '%private-ioblock-read-u64-byte)
2815                     (:lock '%locked-ioblock-read-u64-byte)
2816                     (t '%ioblock-read-u64-byte)))
2817                  #+64-bit-target
2818                  ((= subtag target::subtag-s64-vector)
2819                   (setf (ioblock-read-byte-when-locked-function ioblock)
2820                         '%ioblock-read-s64-byte)
2821                   (case sharing
2822                     (:private '%private-ioblock-read-s64-byte)
2823                     (:lock '%locked-ioblock-read-s64-byte)
2824                     (t '%ioblock-read-s64-byte)))
2825                  ;; Not sure what this means, currently.
2826                  (t
2827                   (setf (ioblock-read-byte-when-locked-function ioblock)
2828                         '%general-ioblock-read-byte)
2829                   '%general-ioblock-read-byte))))))
2830
2831(defun install-ioblock-input-line-termination (ioblock line-termination)
2832  (when line-termination
2833    (let* ((sharing (ioblock-sharing ioblock)))
2834      (setf (ioblock-read-char-without-translation-when-locked-function ioblock)
2835            (ioblock-read-char-when-locked-function ioblock)
2836            (ioblock-character-read-vector-function ioblock)
2837            '%ioblock-encoded-character-read-vector
2838            (ioblock-read-line-function ioblock) '%ioblock-encoded-read-line)
2839      (ecase line-termination
2840        (:cr (setf (ioblock-read-char-when-locked-function ioblock)
2841                   '%ioblock-read-char-translating-cr-to-newline
2842                   (ioblock-read-char-function ioblock)
2843                   (case sharing
2844                     (:private
2845                      '%private-ioblock-read-char-translating-cr-to-newline)
2846                     (:lock
2847                      '%locked-ioblock-read-char-translating-cr-to-newline)
2848                     (t '%ioblock-read-char-translating-cr-to-newline))))
2849        (:crlf (setf (ioblock-read-char-when-locked-function ioblock)
2850                     '%ioblock-read-char-translating-crlf-to-newline
2851                     (ioblock-read-char-function ioblock)
2852                     (case sharing
2853                       (:private
2854                        '%private-ioblock-read-char-translating-crlf-to-newline)
2855                       (:lock
2856                        '%locked-ioblock-read-char-translating-crlf-to-newline)
2857                       (t '%ioblock-read-char-translating-crlf-to-newline))))
2858        (:unicode (setf (ioblock-read-char-when-locked-function ioblock)
2859                        '%ioblock-read-char-translating-line-separator-to-newline
2860                        (ioblock-read-char-function ioblock)
2861                        (case sharing
2862                          (:private
2863                           '%private-ioblock-read-char-translating-line-separator-to-newline)
2864                          (:lock
2865                           '%locked-ioblock-read-char-translating-line-separator-to-newline)
2866                          (t '%ioblock-read-char-translating-line-separator-to-newline)))))
2867      (setf (ioblock-line-termination ioblock) line-termination))))
2868 
2869(defun setup-ioblock-output (ioblock character-p element-type sharing encoding line-termination)
2870  (or (ioblock-sharing ioblock)
2871      (setf (ioblock-sharing ioblock) sharing))
2872  (when character-p
2873    (setf (ioblock-encode-literal-char-code-limit ioblock)
2874          (if encoding
2875            (character-encoding-encode-literal-char-code-limit encoding)
2876            256))   
2877    (if encoding
2878      (let* ((unit-size (character-encoding-code-unit-size encoding)))
2879        (setf (ioblock-encode-output-function ioblock)
2880              (character-encoding-stream-encode-function encoding))
2881        (setf (ioblock-write-char-function ioblock)
2882              (ecase unit-size
2883                (8
2884                 (setf (ioblock-write-char-when-locked-function ioblock)
2885                       '%ioblock-write-u8-encoded-char) 
2886                 (case sharing
2887                   (:private '%private-ioblock-write-u8-encoded-char)
2888                   (:lock '%locked-ioblock-write-u8-encoded-char)
2889                   (t '%ioblock-write-u8-encoded-char)))
2890                (16
2891                 (if (character-encoding-native-endianness encoding)
2892                   (progn
2893                     (setf (ioblock-write-char-when-locked-function ioblock)
2894                           '%ioblock-write-u16-encoded-char) 
2895                     (case sharing
2896                       (:private '%private-ioblock-write-u16-encoded-char)
2897                       (:lock '%locked-ioblock-write-u16-encoded-char)
2898                       (t '%ioblock-write-u16-encoded-char)))
2899                   (progn
2900                     (setf (ioblock-write-char-when-locked-function ioblock)
2901                           '%ioblock-write-swapped-u16-encoded-char)
2902                     (case sharing
2903                       (:private '%private-ioblock-write-swapped-u16-encoded-char)
2904                       (:lock '%locked-ioblock-write-swapped-u16-encoded-char)
2905                       (t '%ioblock-write-swapped-u16-encoded-char)))))
2906                (32
2907                 (if (character-encoding-native-endianness encoding)
2908                   (progn
2909                     (setf (ioblock-write-char-when-locked-function ioblock)
2910                           #'%ioblock-write-u32-encoded-char) 
2911                     (case sharing
2912                       (:private #'%private-ioblock-write-u32-encoded-char)
2913                       (:lock #'%locked-ioblock-write-u32-encoded-char)
2914                       (t #'%ioblock-write-u32-encoded-char)))
2915                   (progn
2916                     (setf (ioblock-write-char-when-locked-function ioblock)
2917                           #'%ioblock-write-swapped-u32-encoded-char)
2918                     (case sharing
2919                       (:private #'%private-ioblock-write-swapped-u32-encoded-char)
2920                       (:lock #'%locked-ioblock-write-swapped-u32-encoded-char)
2921                       (t #'%ioblock-write-swapped-u32-encoded-char)))))))
2922        (setf (ioblock-write-simple-string-function ioblock)
2923              (ecase unit-size
2924                (8 '%ioblock-write-u8-encoded-simple-string)
2925                (16
2926                 (if (character-encoding-native-endianness encoding)
2927                   '%ioblock-write-u16-encoded-simple-string
2928                   '%ioblock-write-swapped-u16-encoded-simple-string))
2929                (32
2930                 (if (character-encoding-native-endianness encoding)
2931                   #'%ioblock-write-u32-encoded-simple-string
2932                   #'%ioblock-write-swapped-u32-encoded-simple-string))))
2933        (when (character-encoding-use-byte-order-mark encoding)
2934          (setf (ioblock-pending-byte-order-mark ioblock) t)))
2935      (progn
2936        (setf (ioblock-write-simple-string-function ioblock)
2937              '%ioblock-unencoded-write-simple-string)
2938        (setf (ioblock-write-char-when-locked-function ioblock)
2939              '%ioblock-write-char)
2940        (setf (ioblock-write-char-function ioblock)
2941              (case sharing
2942                (:private '%private-ioblock-write-char)
2943                (:lock '%locked-ioblock-write-char)
2944                (t '%ioblock-write-char)))))
2945    (when line-termination
2946      (install-ioblock-output-line-termination ioblock line-termination)))
2947  (unless (or (eq element-type 'character)
2948              (subtypep element-type 'character))
2949    (let* ((subtag (element-type-subtype element-type)))
2950      (declare (type (unsigned-byte 8) subtag))
2951      (setf (ioblock-write-byte-function ioblock)
2952            (cond ((= subtag target::subtag-u8-vector)
2953                   (progn
2954                     (setf (ioblock-write-byte-when-locked-function ioblock)
2955                           '%ioblock-write-u8-byte)
2956                     (case sharing
2957                       (:private '%private-ioblock-write-u8-byte)
2958                       (:lock '%locked-ioblock-write-u8-byte)
2959                       (t '%ioblock-write-u8-byte))))
2960                  ((= subtag target::subtag-s8-vector)
2961                   (setf (ioblock-write-byte-when-locked-function ioblock)
2962                         '%ioblock-write-s8-byte)                   
2963                   (case sharing
2964                     (:private '%private-ioblock-write-s8-byte)
2965                     (:lock '%locked-ioblock-write-s8-byte)
2966                     (t '%ioblock-write-s8-byte)))
2967                  ((= subtag target::subtag-u16-vector)
2968                   (setf (ioblock-write-byte-when-locked-function ioblock)
2969                         '%ioblock-write-u16-byte)                   
2970                   (case sharing
2971                     (:private '%private-ioblock-write-u16-byte)
2972                     (:lock '%locked-ioblock-write-u16-byte)
2973                     (t '%ioblock-write-u16-byte)))
2974                  ((= subtag target::subtag-s16-vector)
2975                   (setf (ioblock-write-byte-when-locked-function ioblock)
2976                         '%ioblock-write-s16-byte)                                     
2977                   (case sharing
2978                     (:private '%private-ioblock-write-s16-byte)
2979                     (:lock '%locked-ioblock-write-s16-byte)
2980                     (t '%ioblock-write-s16-byte)))
2981                  ((= subtag target::subtag-u32-vector)
2982                   (setf (ioblock-write-byte-when-locked-function ioblock)
2983                         '%ioblock-write-u32-byte)                                     
2984                   (case sharing
2985                     (:private '%private-ioblock-write-u32-byte)
2986                     (:lock '%locked-ioblock-write-u32-byte)
2987                     (t '%ioblock-write-u32-byte)))
2988                  ((= subtag target::subtag-s32-vector)
2989                   (setf (ioblock-write-byte-when-locked-function ioblock)
2990                         '%ioblock-write-s32-byte)
2991                   (case sharing
2992                     (:private '%private-ioblock-write-s32-byte)
2993                     (:lock '%locked-ioblock-write-s32-byte)
2994                     (t '%ioblock-write-s32-byte)))
2995                  #+64-bit-target
2996                  ((= subtag target::subtag-u64-vector)
2997                   (setf (ioblock-write-byte-when-locked-function ioblock)
2998                         '%ioblock-write-u64-byte)
2999                   (case sharing
3000                     (:private '%private-ioblock-write-u64-byte)
3001                     (:lock '%locked-ioblock-write-u64-byte)
3002                     (t '%ioblock-write-u64-byte)))
3003                  #+64-bit-target
3004                  ((= subtag target::subtag-s64-vector)
3005                   (setf (ioblock-write-byte-when-locked-function ioblock)
3006                         '%ioblock-write-u64-byte)
3007                   (case sharing
3008                     (:private '%private-ioblock-write-s64-byte)
3009                     (:lock '%locked-ioblock-write-s64-byte)
3010                     (t '%ioblock-write-s64-byte)))
3011                  (t
3012                   (setf (ioblock-write-byte-when-locked-function ioblock)
3013                         '%general-ioblock-write-byte)                   
3014                   '%general-ioblock-write-byte))))))
3015
3016(defun install-ioblock-output-line-termination (ioblock line-termination)
3017  (let* ((sharing (ioblock-sharing ioblock)))
3018        (when line-termination
3019      (setf (ioblock-write-char-without-translation-when-locked-function ioblock)
3020            (ioblock-write-char-when-locked-function ioblock)
3021            (ioblock-write-simple-string-function ioblock)
3022            '%ioblock-write-simple-string-with-newline-translation)
3023      (ecase line-termination
3024        (:cr (setf (ioblock-write-char-when-locked-function ioblock)
3025                   '%ioblock-write-char-translating-newline-to-cr
3026                   (ioblock-read-char-function ioblock)
3027                   (case sharing
3028                     (:private
3029                      '%private-ioblock-write-char-translating-newline-to-cr)
3030                     (:lock
3031                      '%locked-ioblock-write-char-translating-newline-to-cr)
3032                     (t '%ioblock-write-char-translating-newline-to-cr))))
3033        (:crlf (setf (ioblock-write-char-when-locked-function ioblock)
3034                     '%ioblock-write-char-translating-newline-to-crlf
3035                     (ioblock-write-char-function ioblock)
3036                     (case sharing
3037                       (:private
3038                        '%private-ioblock-write-char-translating-newline-to-crlf)
3039                       (:lock
3040                        '%locked-ioblock-write-char-translating-newline-to-crlf)
3041                       (t '%ioblock-write-char-translating-newline-to-crlf))))
3042        (:unicode (setf (ioblock-write-char-when-locked-function ioblock)
3043                        '%ioblock-write-char-translating-newline-to-line-separator
3044                        (ioblock-write-char-function ioblock)
3045                        (case sharing
3046                          (:private
3047                           '%private-ioblock-write-char-translating-newline-to-line-separator)
3048                          (:lock
3049                           '%locked-ioblock-write-char-translating-newline-to-line-separator)
3050                          (t '%ioblock-write-char-translating-newline-to-line-separator)))))
3051      (setf (ioblock-line-termination ioblock) line-termination))))
3052
3053
3054(defun ensure-reasonable-element-type (element-type)
3055  (let* ((upgraded (upgraded-array-element-type element-type)))
3056    (if (eq upgraded 'bit)
3057      '(unsigned-byte 8)
3058      (if (eq upgraded 'fixnum)
3059        #+64-bit-target '(signed-byte 64) #+32-bit-target '(signed-byte 32)
3060        (if (eq upgraded t)
3061          (error "Stream element-type ~s can't be reasonably supported." element-type)
3062          upgraded)))))
3063
3064(defun init-stream-ioblock (stream
3065                            &key
3066                            insize      ; integer to allocate inbuf here, nil
3067                                        ; otherwise
3068                            outsize     ; integer to allocate outbuf here, nil
3069                                        ; otherwise
3070                            share-buffers-p ; true if input and output
3071                                        ; share a buffer
3072                            element-type
3073                            device
3074                            advance-function
3075                            listen-function
3076                            eofp-function
3077                            force-output-function
3078                            close-function
3079                            element-shift
3080                            interactive
3081                            (sharing :private)
3082                            character-p
3083                            encoding
3084                            line-termination
3085                            input-timeout
3086                            output-timeout
3087                            deadline
3088                            &allow-other-keys)
3089  (declare (ignorable element-shift))
3090  (setq line-termination (cdr (assoc line-termination *canonical-line-termination-conventions*)))
3091  (when encoding
3092    (unless (typep encoding 'character-encoding)
3093      (setq encoding (get-character-encoding encoding)))
3094    (if (eq encoding (get-character-encoding nil))
3095      (setq encoding nil)))
3096  (when sharing
3097    (unless (or (eq sharing :private)
3098                (eq sharing :lock))
3099      (if (eq sharing :external)
3100        (setq sharing nil)
3101        (report-bad-arg sharing '(member nil :private :lock :external)))))
3102  (let* ((ioblock (or (let* ((ioblock (stream-ioblock stream nil)))
3103                        (when ioblock
3104                          (setf (ioblock-stream ioblock) stream)
3105                          ioblock))
3106                      (stream-create-ioblock stream))))
3107    (when (eq sharing :private)
3108      (setf (ioblock-owner ioblock) 0))
3109    (setf (ioblock-encoding ioblock) encoding)
3110    (when insize
3111      (unless (ioblock-inbuf ioblock)
3112        (multiple-value-bind (buffer ptr in-size-in-octets)
3113            (make-heap-ivector insize
3114                               (if character-p
3115                                 '(unsigned-byte 8)
3116                                 (setq element-type
3117                                       (ensure-reasonable-element-type element-type))))
3118          (setf (ioblock-inbuf ioblock)
3119                (make-io-buffer :buffer buffer
3120                                :bufptr ptr
3121                                :size in-size-in-octets
3122                                :limit insize))
3123          (when (eq sharing :lock)
3124            (setf (ioblock-inbuf-lock ioblock) (make-lock)))
3125          (setf (ioblock-line-termination ioblock) line-termination)
3126          (setup-ioblock-input ioblock character-p element-type sharing encoding line-termination)
3127          (setf (ioblock-element-shift ioblock) (max 0 (ceiling (log  (/ in-size-in-octets insize) 2))))
3128          )))
3129    (if share-buffers-p
3130      (if insize
3131        (progn (setf (ioblock-outbuf ioblock)
3132                     (ioblock-inbuf ioblock))
3133               (setf (ioblock-outbuf-lock ioblock)
3134                     (ioblock-inbuf-lock ioblock)))
3135        (error "Can't share buffers unless insize is non-zero and non-null"))
3136      (when outsize
3137        (unless (ioblock-outbuf ioblock)
3138          (multiple-value-bind (buffer ptr out-size-in-octets)
3139              (make-heap-ivector outsize
3140                                 (if character-p
3141                                   '(unsigned-byte 8)
3142                                   (setq element-type (ensure-reasonable-element-type element-type))))
3143            (setf (ioblock-outbuf ioblock)
3144                  (make-io-buffer :buffer buffer
3145                                  :bufptr ptr
3146                                  :count 0
3147                                  :limit outsize
3148                                  :size out-size-in-octets))
3149            (when (eq sharing :lock)
3150              (setf (ioblock-outbuf-lock ioblock) (make-lock)))
3151            (setf (ioblock-element-shift ioblock) (max 0 (ceiling (log (/ out-size-in-octets outsize) 2))))
3152            ))))
3153    (when (or share-buffers-p outsize)
3154      (setup-ioblock-output ioblock character-p element-type sharing encoding line-termination))
3155    (when element-type
3156      (setf (ioblock-element-type ioblock) (if character-p 'character element-type)))
3157;    (when element-shift
3158;      (setf (ioblock-element-shift ioblock) element-shift))
3159    (when device
3160      (setf (ioblock-device ioblock) device))
3161    (when advance-function
3162      (setf (ioblock-advance-function ioblock) advance-function))
3163    (when listen-function
3164      (setf (ioblock-listen-function ioblock) listen-function))
3165    (when eofp-function
3166      (setf (ioblock-eofp-function ioblock) eofp-function))
3167    (when force-output-function
3168      (setf (ioblock-force-output-function ioblock) force-output-function))
3169    (when close-function
3170      (setf (ioblock-close-function ioblock) close-function))
3171    (when interactive
3172      (setf (ioblock-interactive ioblock) interactive))
3173    (setf (stream-ioblock stream) ioblock)
3174    (when encoding
3175      (setf (ioblock-native-byte-order ioblock)
3176            (character-encoding-native-endianness encoding)))
3177    (let* ((bom-info (and insize encoding (character-encoding-use-byte-order-mark encoding))))
3178      (when bom-info
3179        (ioblock-check-input-bom ioblock bom-info sharing)))
3180    (setf (ioblock-input-timeout ioblock) input-timeout)
3181    (setf (ioblock-output-timeout ioblock) output-timeout)
3182    (setf (ioblock-deadline ioblock) deadline)
3183    ioblock))
3184
3185;;; If there's a byte-order-mark (or a reversed byte-order-mark) at
3186;;; the beginning of the input stream, deal with it.  If there's any
3187;;; input present, make sure that we don't write a BOM on output.  If
3188;;; this is a little-endian machine, input data was present, and there
3189;;; was no BOM in that data, make things big-endian.  If there's a
3190;;; leading BOM or swapped BOM, eat it (consume it so that it doesn't
3191;;; ordinarily appear as input.)
3192;;;
3193(defun ioblock-check-input-bom (ioblock swapped-encoding-name sharing)
3194  (let* ((n (%ioblock-advance ioblock nil))) ; try to read, don't block
3195    (when n
3196      (setf (ioblock-pending-byte-order-mark ioblock) nil)
3197      (let* ((inbuf (ioblock-inbuf ioblock))
3198             (unit-size (character-encoding-code-unit-size (ioblock-encoding ioblock)))
3199             (min (ash unit-size -3))
3200             (buf (io-buffer-buffer inbuf))
3201             (swapped-encoding
3202              (and
3203               (>= n min)
3204               (case (case unit-size
3205                       (16 (%native-u8-ref-u16 buf 0))
3206                       (32 (%native-u8-ref-u32 buf 0)))
3207                 (#.byte-order-mark-char-code
3208                  (setf (io-buffer-idx inbuf) min)
3209                  nil)
3210                 (#.swapped-byte-order-mark-char-code
3211                  (setf (io-buffer-idx inbuf) min)
3212                  t)
3213                 (t #+little-endian-target t))
3214               (lookup-character-encoding swapped-encoding-name))))
3215        (when swapped-encoding
3216          (let* ((output-p (not (null (ioblock-outbuf ioblock)))))
3217            (setf (ioblock-native-byte-order ioblock)
3218                  (character-encoding-native-endianness swapped-encoding))
3219            (ecase unit-size
3220              (16
3221               (setf (ioblock-read-char-when-locked-function ioblock)
3222                     '%ioblock-read-swapped-u16-encoded-char)
3223               (case sharing
3224                 (:private '%private-ioblock-read-swapped-u16-encoded-char)
3225                 (:lock '%locked-ioblock-read-swapped-u16-encoded-char)
3226                 (t '%ioblock-read-swapped-u16-encoded-char)))
3227              (32
3228               (setf (ioblock-read-char-when-locked-function ioblock)
3229                     '%ioblock-read-swapped-u32-encoded-char)
3230               (case sharing
3231                 (:private '%private-ioblock-read-swapped-u32-encoded-char)
3232                 (:lock '%locked-ioblock-read-swapped-u32-encoded-char)
3233                 (t '%ioblock-read-swapped-u16-encoded-char))))
3234            (when output-p
3235              (ecase unit-size
3236                (16
3237                 (setf (ioblock-write-char-when-locked-function ioblock)
3238                       '%ioblock-write-swapped-u16-encoded-char)
3239                 (case sharing
3240                   (:private '%private-ioblock-write-swapped-u16-encoded-char)
3241                   (:lock '%locked-ioblock-write-swapped-u16-encoded-char)
3242                   (t '%ioblock-write-swapped-u16-encoded-char))
3243                 (setf (ioblock-write-simple-string-function ioblock)
3244                       '%ioblock-write-swapped-u16-encoded-simple-string))
3245                (32
3246                 (setf (ioblock-write-char-when-locked-function ioblock)
3247                       '%ioblock-write-swapped-u32-encoded-char)
3248                 (case sharing
3249                   (:private '%private-ioblock-write-swapped-u32-encoded-char)
3250                   (:lock '%locked-ioblock-write-swapped-u32-encoded-char)
3251                   (t '%ioblock-write-swapped-u32-encoded-char))
3252                 (setf (ioblock-write-simple-string-function ioblock)
3253                       '%ioblock-write-swapped-u32-encoded-simple-string))))))))))
3254
3255
3256
3257;;; We can't define a MAKE-INSTANCE method on STRUCTURE-CLASS subclasses
3258;;; in MCL; of course, calling the structure-class's constructor does
3259;;; much the same thing (but note that MCL only keeps track of the
3260;;; default, automatically generated constructor.)
3261;;; (As fascinating as that may be, that has nothing to do with any
3262;;; nearby code, though it may have once been relevant.)
3263(defun make-ioblock-stream (class
3264                            &rest initargs
3265                            &key 
3266                            &allow-other-keys)
3267  (declare (dynamic-extent initargs))
3268  (let* ((s
3269          (if (subtypep class 'basic-stream)
3270            (apply #'make-basic-stream-instance class :allow-other-keys t initargs)
3271            (apply #'make-instance class :allow-other-keys t initargs))))
3272    (apply #'init-stream-ioblock s initargs)
3273    s))
3274
3275
3276
3277
3278
3279(defmethod select-stream-class ((s symbol) in-p out-p char-p)
3280  (select-stream-class (class-prototype (find-class s)) in-p out-p char-p))
3281
3282(defmethod select-stream-class ((s structure-class) in-p out-p char-p)
3283  (select-stream-class (class-prototype s) in-p out-p char-p))
3284
3285(defmethod select-stream-class ((s standard-class) in-p out-p char-p)
3286  (select-stream-class (class-prototype s) in-p out-p char-p))
3287
3288
3289(defparameter *canonical-line-termination-conventions*
3290  '((:unix . nil)
3291    (:macos . :cr)
3292    (:cr . :cr)
3293    (:crlf . :crlf)
3294    (:cp/m . :crlf)
3295    (:msdos . :crlf)
3296    (:dos . :crlf)
3297    (:windows . :crlf)
3298    (:inferred . nil)
3299    (:unicode . :unicode)))
3300
3301
3302(defun optimal-buffer-size (fd element-type)
3303  #+windows-target (declare (ignore fd))
3304  (let* (#-windows-target (nominal (or (nth-value 6 (%fstat fd)) *elements-per-buffer*))
3305         (octets #+windows-target #$BUFSIZ
3306                 #-windows-target
3307                 (case (%unix-fd-kind fd)
3308                   (:pipe (#_fpathconf fd #$_PC_PIPE_BUF))
3309                   (:socket
3310                    #+linux-target nominal
3311                    #-linux-target
3312                    (int-getsockopt fd #$SOL_SOCKET
3313                                    #+solaris-target #$SO_SNDBUF
3314                                    #-solaris-target #$SO_SNDLOWAT))
3315                   ((:character-special :tty) (#_fpathconf fd #$_PC_MAX_INPUT))
3316                   (t nominal))))
3317    (case (subtag-bytes (element-type-subtype element-type) 1)
3318      (1 octets)
3319      (2 (ash octets -1))
3320      (4 (ash octets -2))
3321      (8 (ash octets -3)))))
3322
3323
3324
3325
3326
3327(defun milliseconds-until-deadline (deadline ioblock)
3328  (let* ((now (get-internal-real-time)))
3329    (if (> now deadline)
3330      (error 'communication-deadline-expired :stream (ioblock-stream ioblock))
3331      (values (round (- deadline now) (/ internal-time-units-per-second 1000))))))
3332
3333
3334;;; Note that we can get "bivalent" streams by specifiying :character-p t
3335;;; with a reasonable element-type (e.g. (UNSIGNED-BYTE 8))
3336(defun make-fd-stream (fd &key
3337                          (direction :input)
3338                          (interactive t)
3339                          (element-type 'character)
3340                          (class 'fd-stream)
3341                          (sharing :private)
3342                          (character-p (or (eq element-type 'character)
3343                                           (subtypep element-type 'character)))
3344                          (basic nil)
3345                          encoding
3346                          line-termination
3347                          auto-close
3348                          input-timeout
3349                          output-timeout
3350                          deadline)
3351  (let* ((elements-per-buffer (optimal-buffer-size fd element-type)))
3352    (when line-termination
3353      (setq line-termination
3354            (cdr (assoc line-termination *canonical-line-termination-conventions*))))
3355    (when basic
3356      (setq class (map-to-basic-stream-class-name class))
3357      (setq basic (subtypep (find-class class) 'basic-stream)))
3358    (let* ((in-p (member direction '(:io :input)))
3359           (out-p (member direction '(:io :output)))
3360           (class-name (select-stream-class class in-p out-p character-p))
3361           (class (find-class class-name))
3362           (stream
3363            (make-ioblock-stream class
3364                                 :insize (if in-p elements-per-buffer)
3365                                 :outsize (if out-p elements-per-buffer)
3366                                 :device fd
3367                                 :interactive interactive
3368                                 :element-type element-type
3369                                 :advance-function (if in-p
3370                                                     (select-stream-advance-function class direction))
3371                                 :listen-function (if in-p 'fd-stream-listen)
3372                                 :eofp-function (if in-p 'fd-stream-eofp)
3373                                 :force-output-function (if out-p
3374                                                          (select-stream-force-output-function class direction))
3375                                 :close-function 'fd-stream-close
3376                                 :sharing sharing
3377                                 :character-p character-p
3378                                 :encoding encoding
3379                                 :line-termination line-termination
3380                                 :input-timeout input-timeout
3381                                 :output-timeout output-timeout
3382                                 :deadline deadline)))
3383      (if auto-close
3384        (terminate-when-unreachable stream
3385                                    (lambda (stream)
3386                                      (close-for-termination stream t))))
3387      stream)))
3388
3389 
3390;;;  Fundamental streams.
3391
3392(defclass fundamental-stream (stream)
3393    ())
3394
3395(defclass fundamental-input-stream (fundamental-stream input-stream)
3396    ((shared-resource :initform nil :accessor input-stream-shared-resource)))
3397
3398(defclass fundamental-output-stream (fundamental-stream output-stream)
3399    ())
3400
3401(defmethod input-stream-p ((x t))
3402  (report-bad-arg x 'stream))
3403                           
3404(defmethod input-stream-p ((s input-stream))
3405  t)
3406
3407(defmethod output-stream-p ((x t))
3408  (report-bad-arg x 'stream))
3409
3410(defmethod output-stream-p ((s input-stream))
3411  (typep s 'output-stream))
3412
3413(defmethod output-stream-p ((s output-stream))
3414  t)
3415
3416(defmethod input-stream-p ((s output-stream))
3417  (typep s 'input-stream))
3418
3419(defclass binary-stream (stream)
3420    ())
3421
3422(defclass character-stream (stream)
3423    ())
3424
3425(defmethod stream-external-format ((s character-stream))
3426  (make-external-format :character-encoding #+big-endian-target :utf-32be #+little-endian-target :utf-32le :line-termination :unix))
3427
3428
3429(defmethod (setf stream-external-format) (new (s character-stream))
3430  (check-type new external-format)
3431  (stream-external-format s))
3432
3433
3434(defclass fundamental-character-stream (fundamental-stream character-stream)
3435    ())
3436
3437(defmethod stream-element-type ((s fundamental-character-stream))
3438  'character)
3439
3440(defclass fundamental-binary-stream (fundamental-stream binary-stream)
3441    ())
3442
3443(defclass character-input-stream (input-stream character-stream)
3444    ())
3445
3446(defclass fundamental-character-input-stream (fundamental-input-stream
3447                                              fundamental-character-stream
3448                                              character-input-stream)
3449    ())
3450
3451(defmethod stream-read-char-no-hang ((s fundamental-character-input-stream))
3452  (stream-read-char s))
3453
3454(defmethod stream-peek-char ((s fundamental-character-input-stream))
3455  (let* ((ch (stream-read-char s)))
3456    (unless (eq ch :eof)
3457      (stream-unread-char s ch))
3458    ch))
3459
3460(defmethod stream-listen ((s fundamental-character-input-stream))
3461  (let* ((ch (stream-read-char-no-hang s)))
3462    (when (and ch (not (eq ch :eof)))
3463      (stream-unread-char s ch))
3464    ch))
3465
3466(defmethod stream-clear-input ((s fundamental-character-input-stream))
3467  )
3468
3469(defmethod stream-read-line ((s character-input-stream))
3470  (generic-read-line s))
3471
3472(defclass character-output-stream (output-stream character-stream)
3473    ())
3474
3475(defclass fundamental-character-output-stream (fundamental-output-stream
3476                                               fundamental-character-stream
3477                                               character-output-stream)
3478    ())
3479
3480(defclass binary-input-stream (input-stream binary-stream)
3481    ())
3482
3483(defclass fundamental-binary-input-stream (fundamental-input-stream
3484                                           fundamental-binary-stream
3485                                           binary-input-stream)
3486    ())
3487
3488(defclass binary-output-stream (output-stream binary-stream)
3489    ())
3490
3491(defclass fundamental-binary-output-stream (fundamental-output-stream
3492                                            fundamental-binary-stream
3493                                            binary-output-stream)
3494    ())
3495
3496
3497
3498(defmethod stream-read-byte ((s t))
3499  (report-bad-arg s '(and input-stream binary-stream)))
3500
3501(defmethod stream-write-byte ((s t) b)
3502  (declare (ignore b))
3503  (report-bad-arg s '(and output-stream binary-stream)))
3504
3505(defmethod stream-length ((s stream) &optional new)
3506  (declare (ignore new)))
3507
3508(defmethod stream-start-line-p ((s character-output-stream))
3509  (eql 0 (stream-line-column s)))
3510
3511(defmethod stream-terpri ((s character-output-stream))
3512  (stream-write-char s #\Newline))
3513
3514(defmethod stream-fresh-line ((s character-output-stream))
3515  (unless (stream-start-line-p s)
3516    (stream-terpri s)
3517    t))
3518
3519;;; The bad news is that this doesn't even bother to do the obvious
3520;;; (calling STREAM-WRITE-STRING with a longish string of spaces.)
3521;;; The good news is that this method is pretty useless to (format "~T" ...)
3522;;; anyhow.
3523(defmethod stream-advance-to-column ((s fundamental-character-output-stream)
3524                                     col)
3525  (generic-advance-to-column s col))
3526
3527(defmethod stream-write-string ((stream fundamental-character-output-stream) string &optional (start 0) end)
3528  (generic-stream-write-string stream string start end))
3529
3530
3531;;; The read-/write-vector methods could be specialized for stream classes
3532;;; that expose the underlying buffering mechanism.
3533;;; They can assume that the 'vector' argument is a simple one-dimensional
3534;;; array and that the 'start' and 'end' arguments are sane.
3535
3536(defmethod stream-write-vector ((stream character-output-stream)
3537                                vector start end)
3538  (declare (fixnum start end))
3539  (do* ((i start (1+ i)))
3540       ((= i end))
3541    (declare (fixnum i))
3542    (write-char (uvref vector i) stream)))
3543
3544(defmethod stream-write-vector ((stream binary-output-stream)
3545                                vector start end)
3546  (declare (fixnum start end))
3547  (do* ((i start (1+ i)))
3548       ((= i end))
3549    (declare (fixnum i))
3550    (write-byte (uvref vector i) stream)))
3551
3552(defmethod stream-read-vector ((stream character-input-stream)
3553                               vector start end)
3554  (generic-character-read-vector stream vector start end))
3555
3556
3557(defmethod stream-read-vector ((stream binary-input-stream)
3558                               vector start end)
3559  (declare (fixnum start end))
3560  (do* ((i start (1+ i)))
3561       ((= i end) end)
3562    (declare (fixnum i))
3563    (let* ((b (read-byte stream nil :eof)))
3564      (if (eq b :eof)
3565        (return i)
3566        (setf (uvref vector i) b)))))
3567
3568
3569
3570
3571;;; File streams, in the abstract.
3572
3573(defclass file-stream (stream)
3574    ())
3575
3576(defmethod stream-domain ((s file-stream))
3577  :file)
3578
3579
3580
3581;;; "Basic" (non-extensible) streams.
3582
3583
3584(declaim (inline basic-stream-p))
3585
3586(defun basic-stream-p (x)
3587  (= (the fixnum (typecode x)) target::subtag-basic-stream))
3588
3589(setf (type-predicate 'basic-stream) 'basic-stream-p)
3590
3591(make-built-in-class 'basic-stream 'stream)
3592(make-built-in-class 'basic-file-stream 'basic-stream 'file-stream)
3593(make-built-in-class 'basic-character-stream 'basic-stream 'character-stream)
3594(make-built-in-class 'basic-binary-stream 'basic-stream 'binary-stream)
3595
3596(make-built-in-class 'basic-input-stream 'basic-stream 'input-stream)
3597(make-built-in-class 'basic-output-stream 'basic-stream 'output-stream)
3598(make-built-in-class 'basic-io-stream 'basic-input-stream 'basic-output-stream)
3599(make-built-in-class 'basic-character-input-stream 'basic-input-stream 'basic-character-stream 'character-input-stream)
3600(make-built-in-class 'basic-character-output-stream 'basic-output-stream 'basic-character-stream 'character-output-stream)
3601(make-built-in-class 'basic-character-io-stream 'basic-character-input-stream 'basic-character-output-stream)
3602(make-built-in-class 'basic-binary-input-stream 'basic-input-stream 'basic-binary-stream 'binary-input-stream)
3603(make-built-in-class 'basic-binary-output-stream 'basic-output-stream 'basic-binary-stream 'binary-output-stream)
3604(make-built-in-class 'basic-binary-io-stream 'basic-binary-input-stream 'basic-binary-output-stream)
3605
3606
3607(defun %ioblock-external-format (ioblock)
3608  (let* ((encoding (or (ioblock-encoding ioblock)
3609                       (get-character-encoding nil)))
3610         (line-termination (or (ioblock-line-termination ioblock)
3611                               :unix)))
3612    (make-external-format :character-encoding (character-encoding-name encoding)
3613                          :line-termination line-termination)))
3614
3615(defmethod input-stream-shared-resource ((s basic-input-stream))
3616  (getf (basic-stream.info s) :shared-resource))
3617
3618(defmethod (setf input-stream-shared-resource) (new (s basic-input-stream))
3619  (setf (getf (basic-stream.info s) :shared-resource) new))
3620
3621(defmethod print-object ((s basic-stream) out)
3622  (print-unreadable-object (s out :type t :identity t)
3623    (let* ((ioblock (basic-stream.state s))
3624           (fd (and ioblock (ioblock-device ioblock)))
3625           (encoding (and ioblock (encoding-name (ioblock-encoding ioblock)))))
3626      (if fd
3627        (format out "~a (~a/~d)" encoding (%unix-fd-kind fd) fd)
3628        (format out "~s" :closed)))))
3629
3630(defmethod select-stream-class ((s (eql 'basic-stream)) in-p out-p char-p)
3631  (if char-p
3632    (if in-p
3633      (if out-p
3634        'basic-character-io-stream
3635        'basic-character-input-stream)
3636      'basic-character-output-stream)
3637    (if in-p
3638      (if out-p
3639        'basic-binary-io-stream
3640        'basic-binary-input-stream)
3641      'basic-binary-output-stream)))
3642
3643
3644(defmethod map-to-basic-stream-class-name (name)
3645  name)
3646
3647(defmethod map-to-basic-stream-class-name ((name (eql 'fd-stream)))
3648  'basic-stream)
3649
3650(defun allocate-basic-stream (class)
3651  (if (subtypep class 'basic-file-stream)
3652    (gvector :basic-stream (%class-own-wrapper class) 0 nil nil nil nil nil)
3653    (gvector :basic-stream (%class-own-wrapper class) 0 nil nil)))
3654
3655
3656(defmethod initialize-basic-stream ((s basic-stream) &key &allow-other-keys)
3657  )
3658 
3659(defmethod initialize-basic-stream :after  ((s basic-input-stream) &key &allow-other-keys)
3660  (setf (basic-stream.flags s)
3661        (logior (ash 1 basic-stream-flag.open-input) (basic-stream.flags s))))
3662
3663(defmethod initialize-basic-stream :after ((s basic-output-stream) &key &allow-other-keys)
3664  (setf (basic-stream.flags s)
3665        (logior (ash 1 basic-stream-flag.open-output) (basic-stream.flags s))))
3666
3667(defmethod initialize-basic-stream :after ((s basic-binary-stream) &key &allow-other-keys)
3668  (setf (basic-stream.flags s)
3669        (logior (ash 1 basic-stream-flag.open-binary) (basic-stream.flags s))))
3670
3671(defmethod initialize-basic-stream :after ((s basic-character-stream) &key &allow-other-keys)
3672  (setf (basic-stream.flags s)
3673        (logior (ash 1 basic-stream-flag.open-character) (basic-stream.flags s))))
3674
3675(defun make-basic-stream-instance (class &rest initargs)
3676  (let* ((s (allocate-basic-stream class)))
3677    (apply #'initialize-basic-stream s initargs)
3678    s))
3679
3680
3681
3682(defmethod (setf stream-ioblock) (ioblock (s basic-stream))
3683  (setf (basic-stream.state s) ioblock))
3684
3685(defmethod stream-create-ioblock ((stream basic-stream) &rest args &key)
3686  (declare (dynamic-extent args))
3687  (apply #'make-ioblock :stream stream args))
3688
3689
3690(defmethod stream-write-list ((stream fundamental-character-output-stream)
3691                              list count)
3692  (declare (fixnum count))
3693  (dotimes (i count)
3694    (stream-write-char stream (pop list))))
3695
3696(defmethod stream-write-list ((stream basic-character-output-stream)
3697                              list count)
3698  (declare (fixnum count))
3699  (dotimes (i count)
3700    (stream-write-char stream (pop list))))
3701
3702(defmethod stream-read-list ((stream character-input-stream)
3703                             list count)
3704  (generic-character-read-list stream list count))
3705
3706
3707(defmethod stream-write-list ((stream fundamental-binary-output-stream)
3708                              list count)
3709  (declare (fixnum count))
3710  (dotimes (i count)
3711    (let* ((element (pop list)))
3712      (if (typep element 'character)
3713        (write-char element stream)
3714        (write-byte element stream)))))
3715
3716(defmethod stream-write-list ((stream basic-binary-output-stream)
3717                              list count)
3718  (declare (fixnum count))
3719  (dotimes (i count)
3720    (let* ((element (pop list)))
3721      (if (typep element 'character)
3722        (write-char element stream)
3723        (write-byte element stream)))))
3724
3725(defmethod stream-read-list ((stream binary-input-stream)
3726                             list count)
3727  (declare (fixnum count))
3728  (do* ((tail list (cdr tail))
3729        (i 0 (1+ i)))
3730       ((= i count) count)
3731    (declare (fixnum i))
3732    (let* ((b (read-byte stream nil :eof)))
3733      (if (eq b :eof)
3734        (return i)
3735        (rplaca tail b)))))
3736
3737
3738
3739(defun stream-is-closed (s)
3740  (error "~s is closed" s))
3741
3742(defmethod stream-read-char ((s basic-character-input-stream))
3743  (let* ((ioblock (basic-stream-ioblock s)))
3744    (funcall (ioblock-read-char-function ioblock) ioblock)))
3745
3746
3747(defmethod stream-read-char-no-hang ((stream basic-character-input-stream))
3748  (let* ((ioblock (basic-stream-ioblock stream)))
3749    (with-ioblock-input-locked (ioblock)
3750      (values
3751          (%ioblock-tyi-no-hang ioblock)))))
3752       
3753(defmethod stream-peek-char ((stream basic-character-input-stream))
3754  (let* ((ioblock (basic-stream-ioblock stream)))
3755    (with-ioblock-input-locked (ioblock)
3756      (values
3757       (funcall (ioblock-peek-char-function ioblock) ioblock)))))
3758
3759(defmethod stream-clear-input ((stream basic-character-input-stream))
3760  (let* ((ioblock (basic-stream-ioblock stream)))
3761    (with-ioblock-input-locked (ioblock)
3762      (values
3763        (%ioblock-clear-input ioblock)))))
3764
3765(defmethod stream-unread-char ((s basic-character-input-stream) char)
3766  (let* ((ioblock (basic-stream-ioblock s)))
3767    (with-ioblock-input-locked (ioblock)
3768      (values
3769       (funcall (ioblock-unread-char-function ioblock) ioblock char)))))
3770
3771(defmethod stream-read-ivector ((s basic-binary-input-stream)
3772                                iv start nb)
3773  (let* ((ioblock (basic-stream-ioblock s)))
3774    (with-ioblock-input-locked (ioblock)
3775      (values
3776       (%ioblock-binary-in-ivect ioblock iv start nb)))))
3777
3778(defmethod stream-read-vector ((stream basic-character-input-stream)
3779                               vector start end)
3780  (declare (fixnum start end))
3781  (if (not (typep vector 'simple-base-string))
3782    (generic-character-read-vector stream vector start end)
3783    (let* ((ioblock (basic-stream-ioblock stream)))
3784      (with-ioblock-input-locked (ioblock)
3785        (values
3786         (funcall (ioblock-character-read-vector-function ioblock)
3787                  ioblock vector start end))))))
3788
3789(defmethod stream-read-line ((stream basic-character-input-stream))
3790  (let* ((ioblock (basic-stream-ioblock stream)))
3791    (with-ioblock-input-locked (ioblock)
3792      (funcall (ioblock-read-line-function ioblock) ioblock))))
3793
3794                             
3795;;; Synonym streams.
3796
3797(defclass synonym-stream (fundamental-stream)
3798    ((symbol :initarg :symbol :reader synonym-stream-symbol)))
3799
3800(defmethod print-object ((s synonym-stream) out)
3801  (print-unreadable-object (s out :type t :identity t)
3802    (format out "to ~s" (synonym-stream-symbol s))))
3803
3804(macrolet ((synonym-method (name &rest args)
3805            (let* ((stream (make-symbol "STREAM")))
3806              `(defmethod ,name ((,stream synonym-stream) ,@args)
3807                (,name (symbol-value (synonym-stream-symbol ,stream)) ,@args)))))
3808           (synonym-method stream-read-char)
3809           (synonym-method stream-read-byte)
3810           (synonym-method stream-unread-char c)
3811           (synonym-method stream-read-char-no-hang)
3812           (synonym-method stream-peek-char)
3813           (synonym-method stream-listen)
3814           (synonym-method stream-eofp)
3815           (synonym-method stream-clear-input)
3816           (synonym-method stream-read-line)
3817           (synonym-method stream-read-list l c)
3818           (synonym-method stream-read-vector v start end)
3819           (synonym-method stream-write-char c)
3820           ;(synonym-method stream-write-string str &optional (start 0) end)
3821           (synonym-method stream-write-byte b)
3822           (synonym-method stream-clear-output)
3823           (synonym-method stream-line-column)
3824           (synonym-method stream-set-column new)
3825           (synonym-method stream-advance-to-column new)
3826           (synonym-method stream-start-line-p)
3827           (synonym-method stream-fresh-line)
3828           (synonym-method stream-terpri)
3829           (synonym-method stream-force-output)
3830           (synonym-method stream-finish-output)
3831           (synonym-method stream-write-list l c)
3832           (synonym-method stream-write-vector v start end)
3833           (synonym-method stream-element-type)
3834           (synonym-method input-stream-p)
3835           (synonym-method output-stream-p)
3836           (synonym-method interactive-stream-p)
3837           (synonym-method stream-direction)
3838           (synonym-method stream-device direction)
3839           (synonym-method stream-surrounding-characters)
3840           (synonym-method stream-input-timeout)
3841           (synonym-method stream-output-timeout)
3842           (synonym-method stream-deadline)
3843           (synonym-method stream-eof-transient-p))
3844
3845(defmethod (setf input-stream-timeout) (new (s synonym-stream))
3846  (setf (input-stream-timeout (symbol-value (synonym-stream-symbol s))) new))
3847
3848(defmethod (setf output-stream-timeout) (new (s synonym-stream))
3849  (setf (output-stream-timeout (symbol-value (synonym-stream-symbol s))) new))
3850
3851
3852(defmethod stream-write-string ((s synonym-stream) string &optional (start 0) end)
3853  (stream-write-string (symbol-value (synonym-stream-symbol s)) string start end))
3854
3855(defmethod stream-length ((s synonym-stream) &optional new)
3856  (stream-length (symbol-value (synonym-stream-symbol s)) new))
3857
3858(defmethod stream-position ((s synonym-stream) &optional new)
3859  (stream-position (symbol-value (synonym-stream-symbol s)) new))
3860
3861(defun make-synonym-stream (symbol)
3862  (make-instance 'synonym-stream :symbol (require-type symbol 'symbol)))
3863
3864;;;
3865(defclass composite-stream-mixin ()
3866    ((open-p :initform t)))
3867
3868(defmethod close :after ((stream composite-stream-mixin) &key abort)
3869  (declare (ignore abort))
3870  (with-slots (open-p) stream
3871    (setq open-p nil)))
3872
3873(defmethod open-stream-p ((stream composite-stream-mixin))
3874  (slot-value stream 'open-p))
3875
3876
3877;;; Two-way streams.
3878(defclass two-way-stream (composite-stream-mixin fundamental-input-stream fundamental-output-stream)
3879    ((input-stream :initarg :input-stream :accessor two-way-stream-input-stream)
3880     (output-stream :initarg :output-stream :accessor two-way-stream-output-stream)))
3881
3882(defmethod stream-eof-transient-p ((stream two-way-stream))
3883  (stream-eof-transient-p (two-way-stream-input-stream stream)))
3884
3885(defmethod print-object ((s two-way-stream) out)
3886  (print-unreadable-object (s out :type t :identity t)
3887    (format out "input ~s, output ~s" 
3888            (two-way-stream-input-stream s)
3889            (two-way-stream-output-stream s))))
3890
3891(macrolet ((two-way-input-method (name &rest args)
3892             (let* ((stream (make-symbol "STREAM")))
3893               `(defmethod ,name ((,stream two-way-stream) ,@args)
3894                 (,name (two-way-stream-input-stream ,stream) ,@args))))
3895           (two-way-output-method (name &rest args)
3896             (let* ((stream (make-symbol "STREAM")))
3897               `(defmethod ,name ((,stream two-way-stream) ,@args)
3898                 (,name (two-way-stream-output-stream ,stream) ,@args)))))
3899  (two-way-input-method stream-read-char)
3900  (two-way-input-method stream-read-byte)
3901  (two-way-input-method stream-unread-char c)
3902  (two-way-input-method stream-read-char-no-hang)
3903  (two-way-input-method stream-peek-char)
3904  (two-way-input-method stream-listen)
3905  (two-way-input-method stream-eofp)
3906  (two-way-input-method stream-clear-input)
3907  (two-way-input-method stream-read-line)
3908  (two-way-input-method stream-read-list l c)
3909  (two-way-input-method stream-read-vector v start end)
3910  (two-way-input-method stream-surrounding-characters)
3911  (two-way-input-method stream-input-timeout)
3912  (two-way-input-method interactive-stream-p)
3913  (two-way-output-method stream-write-char c)
3914  (two-way-output-method stream-write-byte b)
3915  (two-way-output-method stream-clear-output)
3916  (two-way-output-method stream-line-column)
3917  (two-way-output-method stream-set-column new)
3918  (two-way-output-method stream-advance-to-column new)
3919  (two-way-output-method stream-start-line-p)
3920  (two-way-output-method stream-fresh-line)
3921  (two-way-output-method stream-terpri)
3922  (two-way-output-method stream-force-output)
3923  (two-way-output-method stream-finish-output)
3924  (two-way-output-method stream-write-list l c)
3925  (two-way-output-method stream-write-vector v start end)
3926  (two-way-output-method stream-output-timeout)
3927  (two-way-output-method stream-deadline))
3928
3929(defmethod (setf stream-input-timeout) (new (s two-way-stream))
3930  (setf (stream-input-timeout (two-way-stream-input-stream s)) new))
3931
3932(defmethod (setf stream-output-timeout) (new (s two-way-stream))
3933  (setf (stream-output-timeout (two-way-stream-output-stream s)) new))
3934
3935(defmethod (setf stream-deadline) (new (s two-way-stream))
3936  (setf (stream-deadline (two-way-stream-output-stream s)) new))
3937
3938(defmethod stream-device ((s two-way-stream) direction)
3939  (case direction
3940    (:input (stream-device (two-way-stream-input-stream s) direction))
3941    (:output (stream-device (two-way-stream-output-stream s) direction))))
3942   
3943(defmethod stream-write-string ((s two-way-stream) string &optional (start 0) end)
3944  (stream-write-string (two-way-stream-output-stream s) string start end))
3945
3946(defmethod stream-element-type ((s two-way-stream))
3947  (let* ((in-type (stream-element-type (two-way-stream-input-stream s)))
3948         (out-type (stream-element-type (two-way-stream-output-stream s))))
3949    (if (equal in-type out-type)
3950      in-type
3951      `(and ,in-type ,out-type))))
3952
3953(defun make-two-way-stream (in out)
3954  "Return a bidirectional stream which gets its input from INPUT-STREAM and
3955   sends its output to OUTPUT-STREAM."
3956  (unless (input-stream-p in)
3957    (require-type in 'input-stream))
3958  (unless (output-stream-p out)
3959    (require-type out 'output-stream))
3960  (make-instance 'two-way-stream :input-stream in :output-stream out))
3961
3962;;; This is intended for use with things like *TERMINAL-IO*, where the
3963;;; OS echoes interactive input.  Whenever we read a character from
3964;;; the underlying input-stream of such a stream, we need to update
3965;;; our notion of the underlying output-stream's STREAM-LINE-COLUMN.
3966
3967(defclass echoing-two-way-stream (two-way-stream)
3968    ())
3969
3970(defmethod stream-read-char ((s echoing-two-way-stream))
3971  (let* ((out (two-way-stream-output-stream s))
3972         (in (two-way-stream-input-stream s)))
3973    (force-output out)
3974    (let* ((ch (stream-read-char in)))
3975      (unless (eq ch :eof)
3976        (if (eq ch #\newline)
3977          (stream-set-column out 0)
3978          (let* ((cur (stream-line-column out)))
3979            (when cur
3980              (stream-set-column out (1+ (the fixnum cur)))))))
3981      ch)))
3982
3983(defmethod stream-read-line ((s echoing-two-way-stream))
3984  (let* ((out (two-way-stream-output-stream s)))
3985    (multiple-value-bind (string eof)
3986        (call-next-method)
3987      (unless eof
3988        (stream-set-column out 0))
3989      (values string eof))))
3990
3991(defun make-echoing-two-way-stream (in out)
3992  (make-instance 'echoing-two-way-stream :input-stream in :output-stream out))
3993
3994;;;echo streams
3995
3996(defclass echo-stream (two-way-stream)
3997    ((did-untyi :initform nil)))
3998
3999(defmethod echo-stream-input-stream ((s echo-stream))
4000  (two-way-stream-input-stream s))
4001
4002(defmethod echo-stream-output-stream ((s echo-stream))
4003  (two-way-stream-output-stream s))
4004
4005(defmethod stream-read-char ((s echo-stream))
4006  (let* ((char (stream-read-char (echo-stream-input-stream s))))
4007    (unless (eq char :eof)
4008      (if (slot-value s 'did-untyi)
4009        (setf (slot-value s 'did-untyi) nil)
4010        (stream-write-char (echo-stream-output-stream s) char)))
4011    char))
4012
4013(defmethod stream-unread-char ((s echo-stream) c)
4014  (call-next-method s c)
4015  (setf (slot-value s 'did-untyi) c))
4016
4017(defmethod stream-read-char-no-hang ((s echo-stream))
4018  (let* ((char (stream-read-char-no-hang (echo-stream-input-stream s))))
4019    (unless (eq char :eof)
4020      (if (slot-value s 'did-untyi)
4021        (setf (slot-value s 'did-untyi) nil)
4022        (stream-write-char (echo-stream-output-stream s) char)))
4023    char))
4024
4025(defmethod stream-clear-input ((s echo-stream))
4026  (call-next-method)
4027  (setf (slot-value s 'did-untyi) nil))
4028
4029(defmethod stream-read-byte ((s echo-stream))
4030  (let* ((byte (stream-read-byte (echo-stream-input-stream s))))
4031    (unless (eq byte :eof)
4032      (stream-write-byte (echo-stream-output-stream s) byte))
4033    byte))
4034
4035(defmethod stream-read-line ((s echo-stream))
4036  (generic-read-line s))
4037
4038(defmethod stream-read-vector ((s echo-stream) vector start end)
4039  (if (subtypep (stream-element-type s) 'character)
4040      (generic-character-read-vector s vector start end)
4041    (generic-binary-read-vector s vector start end)))
4042
4043(defun make-echo-stream (input-stream output-stream)
4044  "Return a bidirectional stream which gets its input from INPUT-STREAM and
4045   sends its output to OUTPUT-STREAM. In addition, all input is echoed to
4046   the output stream."
4047  (make-instance 'echo-stream
4048                 :input-stream input-stream
4049                 :output-stream output-stream))
4050
4051;;;concatenated-streams
4052
4053(defclass concatenated-stream (composite-stream-mixin fundamental-input-stream)
4054    ((streams :initarg :streams :accessor concatenated-stream-streams)))
4055
4056
4057(defun concatenated-stream-current-input-stream (s)
4058  (car (concatenated-stream-streams s)))
4059
4060(defun concatenated-stream-next-input-stream (s)
4061  (setf (concatenated-stream-streams s)
4062        (cdr (concatenated-stream-streams s)))
4063  (concatenated-stream-current-input-stream s))
4064
4065(defmethod stream-element-type ((s concatenated-stream))
4066  (let* ((c (concatenated-stream-current-input-stream s)))
4067    (if c
4068      (stream-element-type c)
4069      nil)))
4070
4071
4072
4073(defmethod stream-read-char ((s concatenated-stream))
4074  (do* ((c (concatenated-stream-current-input-stream s)
4075           (concatenated-stream-next-input-stream s)))
4076       ((null c) :eof)
4077    (let* ((ch (stream-read-char c)))
4078      (unless (eq ch :eof)
4079        (return ch)))))
4080
4081(defmethod stream-read-char-no-hang ((s concatenated-stream))
4082  (do* ((c (concatenated-stream-current-input-stream s)
4083           (concatenated-stream-next-input-stream s)))
4084       ((null c) :eof)
4085    (let* ((ch (stream-read-char-no-hang c)))
4086      (unless (eq ch :eof)
4087        (return ch)))))
4088
4089(defmethod stream-read-byte ((s concatenated-stream))
4090  (do* ((c (concatenated-stream-current-input-stream s)
4091           (concatenated-stream-next-input-stream s)))
4092       ((null c) :eof)
4093    (let* ((b (stream-read-byte c)))
4094      (unless (eq b :eof)
4095        (return b)))))
4096
4097(defmethod stream-peek-char ((s concatenated-stream))
4098  (do* ((c (concatenated-stream-current-input-stream s)
4099       (concatenated-stream-next-input-stream s)))
4100       ((null c) :eof)
4101    (let* ((ch (stream-peek-char c)))
4102      (unless (eq ch :eof)
4103        (return ch)))))
4104
4105(defmethod stream-read-line ((s concatenated-stream))
4106  (generic-read-line s))
4107
4108(defmethod stream-read-list ((s concatenated-stream) list count)
4109  (generic-character-read-list s list count))
4110
4111(defmethod stream-read-vector ((s concatenated-stream) vector start end)
4112  (if (subtypep (stream-element-type s) 'character)
4113      (generic-character-read-vector s vector start end)
4114    (generic-binary-read-vector s vector start end)))
4115
4116(defmethod stream-unread-char ((s concatenated-stream) char)
4117  (let* ((c (concatenated-stream-current-input-stream s)))
4118    (if c
4119      (stream-unread-char c char))))
4120
4121(defmethod stream-listen ((s concatenated-stream))
4122  (do* ((c (concatenated-stream-current-input-stream s)
4123           (concatenated-stream-next-input-stream s)))
4124       ((null c))
4125    (when (stream-listen c)
4126      (return t))))
4127
4128(defmethod stream-eofp ((s concatenated-stream))
4129  (do* ((c (concatenated-stream-current-input-stream s)
4130           (concatenated-stream-next-input-stream s)))
4131       ((null c) t)
4132    (when (stream-listen c)
4133      (return nil))))
4134
4135(defmethod stream-clear-input ((s concatenated-stream))
4136  (let* ((c (concatenated-stream-current-input-stream s)))
4137    (when c (stream-clear-input c))))
4138
4139
4140(defun make-concatenated-stream (&rest streams)
4141  "Return a stream which takes its input from each of the streams in turn,
4142   going on to the next at EOF."
4143  (dolist (s streams (make-instance 'concatenated-stream :streams streams))
4144    (unless (input-stream-p s)
4145      (error "~S is not an input stream" s))))
4146
4147;;;broadcast-streams
4148
4149
4150
4151(defclass broadcast-stream (fundamental-output-stream)
4152    ((streams :initarg :streams :reader broadcast-stream-streams)))
4153
4154(macrolet ((broadcast-method
4155               (op (stream &rest others )
4156                   &optional
4157                   (args (cons stream others)))
4158             (let* ((sub (gensym))
4159                    (result (gensym)))
4160               `(defmethod ,op ((,stream broadcast-stream) ,@others)
4161                 (let* ((,result nil))
4162                   (dolist (,sub (broadcast-stream-streams ,stream) ,result)
4163                             (setq ,result (,op ,@(cons sub (cdr args))))))))))
4164             (broadcast-method stream-write-char (s c))
4165             (broadcast-method stream-write-string
4166                                      (s str &optional (start 0) end)
4167                                      (s str start end))
4168             (broadcast-method stream-write-byte (s b))
4169             (broadcast-method stream-clear-output (s))
4170             (broadcast-method stream-line-column (s))
4171             (broadcast-method stream-set-column (s new))
4172             (broadcast-method stream-advance-to-column (s new))
4173             (broadcast-method stream-start-line-p (s))
4174             (broadcast-method stream-terpri (s))
4175             (broadcast-method stream-force-output (s))
4176             (broadcast-method stream-finish-output (s))
4177             (broadcast-method stream-write-list (s l c))
4178             (broadcast-method stream-write-vector (s v start end)))
4179
4180(defun last-broadcast-stream (s)
4181  (car (last (broadcast-stream-streams s))))
4182
4183(defmethod stream-fresh-line ((s broadcast-stream))
4184  (let* ((did-output-newline nil))
4185    (dolist (sub (broadcast-stream-streams s) did-output-newline)
4186      (setq did-output-newline (stream-fresh-line sub)))))
4187
4188(defmethod stream-element-type ((s broadcast-stream))
4189  (let* ((last (last-broadcast-stream s)))
4190    (if last
4191      (stream-element-type last)
4192      t)))
4193
4194(defmethod stream-length ((s broadcast-stream) &optional new)
4195  (unless new
4196    (let* ((last (last-broadcast-stream s)))
4197      (if last
4198        (stream-length last)
4199        0))))
4200
4201(defmethod stream-position ((s broadcast-stream) &optional new)
4202  (unless new
4203    (let* ((last (last-broadcast-stream s)))
4204      (if last
4205        (stream-position last)
4206        0))))
4207
4208(defun make-broadcast-stream (&rest streams)
4209  (dolist (s streams (make-instance 'broadcast-stream :streams streams))
4210    (unless (output-stream-p s)
4211      (report-bad-arg s '(satisfies output-stream-p)))))
4212
4213
4214
4215;;; String streams.
4216(make-built-in-class 'string-stream 'basic-character-stream)
4217
4218(defmethod print-object ((s string-stream) out)
4219  (print-unreadable-object (s out :type t :identity t)
4220    (unless (open-stream-p s)  (format out " ~s" :closed))))
4221
4222
4223                 
4224
4225(defstruct (string-stream-ioblock (:include ioblock))
4226  string)
4227
4228(defstruct (string-output-stream-ioblock (:include string-stream-ioblock))
4229  (index 0)
4230  freelist)
4231
4232(defstatic *string-output-stream-class* (make-built-in-class 'string-output-stream 'string-stream 'basic-character-output-stream))
4233(defstatic *string-output-stream-class-wrapper* (%class-own-wrapper *string-output-stream-class*))
4234
4235(defstatic *fill-pointer-string-output-stream-class* (make-built-in-class 'fill-pointer-string-output-stream 'string-output-stream))
4236
4237(def-standard-initial-binding %string-output-stream-ioblocks% (%cons-pool nil))
4238
4239(defmethod stream-force-output ((s string-output-stream))
4240  nil)
4241
4242(defmethod stream-finish-output ((s string-output-stream))
4243  nil)
4244
4245(defmethod stream-clear-output ((s string-output-stream))
4246  nil)
4247
4248;;; Should only be used for a stream whose class is exactly
4249;;; *string-output-stream-class*
4250(defun %close-string-output-stream (stream ioblock)
4251  (let* ((pool %string-output-stream-ioblocks%))
4252    (when (and pool
4253               (eq (basic-stream.wrapper stream)
4254                   *string-output-stream-class-wrapper*)
4255               (eq (string-output-stream-ioblock-freelist ioblock) pool))
4256    (without-interrupts
4257     (setf (ioblock-stream ioblock) (pool.data pool)
4258           (pool.data pool) ioblock)))))
4259
4260;;; If this is the sort of string stream whose ioblock we recycle and
4261;;; there's a thread-local binding of the variable we use for a freelist,
4262;;; return the value of that binding.
4263(defun %string-stream-ioblock-freelist (stream)
4264  (and stream
4265       (eq (basic-stream.wrapper stream)
4266           *string-output-stream-class-wrapper*)
4267       (let* ((loc (%tcr-binding-location (%current-tcr) '%string-output-stream-ioblocks%)))
4268         (and loc (%fixnum-ref loc)))))
4269
4270
4271(defun create-string-output-stream-ioblock (&rest keys &key stream &allow-other-keys)
4272  (declare (dynamic-extent keys))
4273  (let* ((recycled (and stream
4274                        (eq (basic-stream.wrapper stream)
4275                            *string-output-stream-class-wrapper*)
4276                        (without-interrupts
4277                         (let* ((data (pool.data %string-output-stream-ioblocks%)))
4278                           (when data
4279                             (setf (pool.data %string-output-stream-ioblocks%)
4280                                   (ioblock-stream data)
4281                                   (ioblock-stream data) stream
4282                                   (ioblock-device data) -1
4283                                   (ioblock-charpos data) 0
4284                                   (string-output-stream-ioblock-index data) 0))
4285                           data)))))
4286    (or recycled (apply #'make-string-output-stream-ioblock keys))))
4287                       
4288
4289
4290(defun %%make-string-output-stream (class string write-char-function write-string-function)
4291  (let* ((stream (allocate-basic-stream class)))
4292    (initialize-basic-stream stream :element-type 'character)
4293    (let* ((ioblock (create-string-output-stream-ioblock
4294                     :stream stream
4295                     :string string
4296                     :element-type 'character
4297                     :write-char-function write-char-function
4298                     :write-char-when-locked-function write-char-function
4299                     :write-simple-string-function write-string-function
4300                     :force-output-function #'false
4301                     :freelist (%string-stream-ioblock-freelist stream)
4302                     :close-function #'%close-string-output-stream)))
4303      (setf (basic-stream.state stream) ioblock)
4304      stream)))
4305
4306(declaim (inline %string-push-extend))
4307(defun %string-push-extend (char string)
4308  (let* ((fill (%svref string target::vectorH.logsize-cell))
4309         (size (%svref string target::vectorH.physsize-cell)))
4310    (declare (fixnum fill size))
4311    (if (< fill size)
4312      (multiple-value-bind (data offset) (array-data-and-offset string)
4313        (declare (simple-string data) (fixnum offset))
4314        (setf (schar data (the fixnum (+ offset fill))) char
4315              (%svref string target::vectorH.logsize-cell) (the fixnum (1+ fill))))
4316      (vector-push-extend char string))))
4317             
4318
4319(defun fill-pointer-string-output-stream-ioblock-write-char (ioblock char)
4320  ;; can do better (maybe much better) than VECTOR-PUSH-EXTEND here.
4321  (if (eql char #\Newline)
4322    (setf (ioblock-charpos ioblock) 0)
4323    (incf (ioblock-charpos ioblock)))
4324  (%string-push-extend char (string-stream-ioblock-string ioblock)))
4325
4326(defun fill-pointer-string-output-stream-ioblock-write-simple-string (ioblock string start-char num-chars)
4327  (let* ((end (+ start-char num-chars))
4328         (nlpos (position #\Newline string :start start-char :end end :from-end t)))
4329    (if nlpos
4330      (setf (ioblock-charpos ioblock) (- end nlpos))
4331      (incf (ioblock-charpos ioblock) num-chars))
4332    (let* ((out (string-stream-ioblock-string ioblock)))
4333      (do* ((n 0 (1+ n))
4334            (i start-char (1+ i)))
4335           ((= n num-chars) num-chars)
4336        (%string-push-extend (schar string i) out)))))
4337
4338(defmethod stream-position ((s fill-pointer-string-output-stream) &optional newpos)
4339  (let* ((string (string-stream-string s)))
4340    (if newpos
4341      (setf (fill-pointer string) newpos)
4342      (fill-pointer string))))
4343
4344;;; If the stream's string is adjustable, it doesn't really have a meaningful
4345;;; "maximum size".
4346(defmethod stream-length ((s string-output-stream) &optional newlen)
4347  (unless newlen
4348    (array-total-size (string-stream-string s))))
4349
4350;;; This creates a FILL-POINTER-STRING-OUTPUT-STREAM.
4351(defun %make-string-output-stream (string)
4352  (unless (and (typep string 'string)
4353               (array-has-fill-pointer-p string))
4354    (error "~S must be a string with a fill pointer." string))
4355  (%%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))
4356
4357(defun string-output-stream-ioblock-write-char (ioblock char)
4358  (let* ((string (string-output-stream-ioblock-string ioblock))
4359         (index (string-output-stream-ioblock-index ioblock))
4360         (len (length string)))
4361    (declare (simple-string string)
4362             (fixnum index len))
4363  (if (eql char #\Newline)
4364    (setf (ioblock-charpos ioblock) 0)
4365    (incf (ioblock-charpos ioblock)))
4366  (if (= index len)
4367      (let* ((newlen (if (zerop len) 20 (+ len len)))      ;non-zero !
4368             (new (make-string newlen)))
4369        (%copy-ivector-to-ivector string 0 new 0 (the fixnum (ash len 2)))
4370        (setq string new)
4371        (setf (string-output-stream-ioblock-string ioblock) new)))
4372    (setf (string-output-stream-ioblock-index ioblock) (the fixnum (1+ index))
4373          (schar string index) char)))
4374
4375(defun string-output-stream-ioblock-write-simple-string (ioblock string start-char num-chars)
4376  (declare (simple-string string)
4377           (fixnum start-char num-chars)
4378           (optimize (speed 3) (safety 0)))
4379  (let* ((out (string-output-stream-ioblock-string ioblock))
4380         (index (string-output-stream-ioblock-index ioblock))
4381         (len (length out))
4382         (need (+ index num-chars)))
4383    (declare (simple-string out)
4384             (fixnum index len need))
4385    (if (< len need)
4386      (let* ((newlen (+ need need))
4387             (new (make-string newlen)))
4388        (declare (fixnum newlen) (simple-string new))
4389        (dotimes (i len)
4390          (setf (schar new i) (schar out i)))
4391        (setq out new)
4392        (setf (string-output-stream-ioblock-string ioblock) new)))
4393    (do* ((src start-char (1+ src))
4394          (dest index (1+ dest))
4395          (nlpos nil)
4396          (end (+ start-char num-chars)))
4397         ((= src end)
4398          (setf (string-output-stream-ioblock-index ioblock) need)
4399          (if nlpos
4400            (setf (ioblock-charpos ioblock) (the fixnum (- end (the fixnum nlpos))))
4401            (incf (ioblock-charpos ioblock) num-chars))
4402          num-chars)
4403      (declare (fixnum src dest end))
4404      (let* ((char (schar string src)))
4405        (if (eql char #\Newline)
4406          (setq nlpos (the fixnum (1+ src))))
4407        (setf (schar out dest) char)))))
4408
4409
4410(defmethod stream-position ((stream string-output-stream) &optional newpos)
4411  (let* ((ioblock (basic-stream-ioblock stream)))
4412    (if (null newpos)
4413      (string-output-stream-ioblock-index ioblock)
4414      (if (and (typep newpos 'fixnum)
4415               (>= (the fixnum newpos) 0)
4416               (<= (the fixnum newpos) (length (string-output-stream-ioblock-string ioblock))))
4417        (setf (string-output-stream-ioblock-index ioblock) newpos)))))
4418
4419(defun make-simple-string-output-stream ()
4420  ;; There's a good chance that we'll get a recycled ioblock
4421  ;; that already has a string; if not, we defer actually
4422  ;; creating a usable string until write-char
4423  (%%make-string-output-stream *string-output-stream-class*
4424                               ""
4425                               'string-output-stream-ioblock-write-char
4426                               'string-output-stream-ioblock-write-simple-string))
4427
4428(defun make-string-output-stream (&key (element-type 'character element-type-p))
4429  "Return an output stream which will accumulate all output given it for
4430   the benefit of the function GET-OUTPUT-STREAM-STRING."
4431  (when (and element-type-p
4432             (not (member element-type '(base-character character