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

Last change on this file since 8486 was 8486, checked in by gb, 13 years ago

Get and set input/output timeouts for streams.
Changes to ioblock may be a little tricky to bootstrap.
Change return values of PROCESS-INPUT-WAIT and PROCESS-OUTPUT-WAIT;
optional second argument is now expressed in milliseconds.

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