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

Last change on this file since 12085 was 11980, checked in by gb, 10 years ago

More stream line-termination stuff.

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