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

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

Store the class-wrapper (not the class) in a BASIC-STREAM.

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