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

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

Changes from ARM branch. Need testing ...

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