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

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

SUBTYPEP compiler macro works better without the FIND-CLASS.

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