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

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

Set ioblock encode/decode "literal limits" in SETUP-IOBLOCK-OUTPUT/INPUT,
so that they're set if the encoding is changed on-the-fly.

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