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

Last change on this file since 10822 was 10822, checked in by gb, 12 years ago

Define GETTIMEOFDAY, which calls lisp_gettimeofday() in the kernel.
(gettimeofday() is prototyped in the mingw headers on Windows but
only available as statically linked code). Change other uses of
#_gettimeofday to call the GETTIMEOFDAY function. Remove some
Windows-specific code that was avoiding use of #_gettimeofday.

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