source: branches/working-0711/ccl/level-1/l1-streams.lisp @ 9949

Last change on this file since 9949 was 9949, checked in by gb, 11 years ago

BASIC-STREAMs store the class-wrapper, not the class.

Try to provide more characters of context info on STREAM-ERRORs.

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