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

Last change on this file since 13636 was 13499, checked in by gb, 10 years ago

Add some whitespace.

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