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

Last change on this file since 14255 was 14255, checked in by gb, 9 years ago

In STREAM-READ-LINE on ECHOING-TWO-WAY-STREAM, call FORCE-OUTPUT
on the output side before reading anything.

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