source: release/1.6/source/level-1/l1-streams.lisp @ 15888

Last change on this file since 15888 was 14468, checked in by rme, 10 years ago

Merge r14459 through r14465 from trunk.

ftype declarations for (setf x) broken
fix for ticket:786
better error checking in alphatizer for FUNCTION
fix protocol handling for Cocotron objc runtime

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 254.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)
3143                (let* ((octets-per-element (/ in-size-in-octets insize)))
3144                  (case octets-per-element
3145                    (1 0)
3146                    (2 1)
3147                    (4 2)
3148                    (8 3)
3149                    (t (max 0 (ceiling (log octets-per-element 2)))))))
3150          )))
3151    (when (ioblock-inbuf ioblock)
3152      (setup-ioblock-input ioblock character-p element-type sharing encoding line-termination))     
3153    (if share-buffers-p
3154      (if insize
3155        (progn (setf (ioblock-outbuf ioblock)
3156                     (ioblock-inbuf ioblock))
3157               (setf (ioblock-outbuf-lock ioblock)
3158                     (ioblock-inbuf-lock ioblock)))
3159        (error "Can't share buffers unless insize is non-zero and non-null"))
3160      (when outsize
3161        (unless (ioblock-outbuf ioblock)
3162          (multiple-value-bind (buffer ptr out-size-in-octets)
3163              (make-heap-ivector outsize
3164                                 (if character-p
3165                                   '(unsigned-byte 8)
3166                                   (setq element-type (ensure-reasonable-element-type element-type))))
3167            (setf (ioblock-outbuf ioblock)
3168                  (make-io-buffer :buffer buffer
3169                                  :bufptr ptr
3170                                  :count 0
3171                                  :limit outsize
3172                                  :size out-size-in-octets))
3173            (when (eq sharing :lock)
3174              (setf (ioblock-outbuf-lock ioblock) (make-lock)))
3175            (setf (ioblock-element-shift ioblock)
3176                  (let* ((octets-per-element (/ out-size-in-octets outsize)))
3177                    (case octets-per-element
3178                      (1 0)
3179                      (2 1)
3180                      (4 2)
3181                      (8 3)
3182                      (t 
3183                       (max 0 (ceiling (log octets-per-element 2)))))))
3184            ))))
3185    (when (ioblock-outbuf ioblock)
3186      (setup-ioblock-output ioblock character-p element-type sharing encoding line-termination))
3187    (when element-type
3188      (setf (ioblock-element-type ioblock) (if character-p 'character element-type)))
3189;    (when element-shift
3190;      (setf (ioblock-element-shift ioblock) element-shift))
3191    (when device
3192      (setf (ioblock-device ioblock) device))
3193    (when advance-function
3194      (setf (ioblock-advance-function ioblock) advance-function))
3195    (when listen-function
3196      (setf (ioblock-listen-function ioblock) listen-function))
3197    (when eofp-function
3198      (setf (ioblock-eofp-function ioblock) eofp-function))
3199    (when force-output-function
3200      (setf (ioblock-force-output-function ioblock) force-output-function))
3201    (when close-function
3202      (setf (ioblock-close-function ioblock) close-function))
3203    (when interactive
3204      (setf (ioblock-interactive ioblock) interactive))
3205    (setf (stream-ioblock stream) ioblock)
3206    (when encoding
3207      (setf (ioblock-native-byte-order ioblock)
3208            (character-encoding-native-endianness encoding)))
3209    (let* ((bom-info (and insize encoding (character-encoding-use-byte-order-mark encoding))))
3210      (when bom-info
3211        (ioblock-check-input-bom ioblock bom-info sharing)))
3212    (setf (ioblock-input-timeout ioblock) input-timeout)
3213    (setf (ioblock-output-timeout ioblock) output-timeout)
3214    (setf (ioblock-deadline ioblock) deadline)
3215    ioblock))
3216
3217;;; If there's a byte-order-mark (or a reversed byte-order-mark) at
3218;;; the beginning of the input stream, deal with it.  If there's any
3219;;; input present, make sure that we don't write a BOM on output.  If
3220;;; this is a little-endian machine, input data was present, and there
3221;;; was no BOM in that data, make things big-endian.  If there's a
3222;;; leading BOM or swapped BOM, eat it (consume it so that it doesn't
3223;;; ordinarily appear as input.)
3224;;;
3225(defun ioblock-check-input-bom (ioblock swapped-encoding-name sharing)
3226  (let* ((n (%ioblock-advance ioblock nil))) ; try to read, don't block
3227    (when n
3228      (setf (ioblock-pending-byte-order-mark ioblock) nil)
3229      (let* ((inbuf (ioblock-inbuf ioblock))
3230             (unit-size (character-encoding-code-unit-size (ioblock-encoding ioblock)))
3231             (min (ash unit-size -3))
3232             (buf (io-buffer-buffer inbuf))
3233             (swapped-encoding
3234              (and
3235               (>= n min)
3236               (case (case unit-size
3237                       (16 (%native-u8-ref-u16 buf 0))
3238                       (32 (%native-u8-ref-u32 buf 0)))
3239                 (#.byte-order-mark-char-code
3240                  (setf (io-buffer-idx inbuf) min)
3241                  nil)
3242                 (#.swapped-byte-order-mark-char-code
3243                  (setf (io-buffer-idx inbuf) min)
3244                  t)
3245                 (t #+little-endian-target t))
3246               (lookup-character-encoding swapped-encoding-name))))
3247        (when swapped-encoding
3248          (let* ((output-p (not (null (ioblock-outbuf ioblock)))))
3249            (setf (ioblock-native-byte-order ioblock)
3250                  (character-encoding-native-endianness swapped-encoding))
3251            (ecase unit-size
3252              (16
3253               (setf (ioblock-read-char-when-locked-function ioblock)
3254                     '%ioblock-read-swapped-u16-encoded-char)
3255               (case sharing
3256                 (:private '%private-ioblock-read-swapped-u16-encoded-char)
3257                 (:lock '%locked-ioblock-read-swapped-u16-encoded-char)
3258                 (t '%ioblock-read-swapped-u16-encoded-char)))
3259              (32
3260               (setf (ioblock-read-char-when-locked-function ioblock)
3261                     '%ioblock-read-swapped-u32-encoded-char)
3262               (case sharing
3263                 (:private '%private-ioblock-read-swapped-u32-encoded-char)
3264                 (:lock '%locked-ioblock-read-swapped-u32-encoded-char)
3265                 (t '%ioblock-read-swapped-u16-encoded-char))))
3266            (when output-p
3267              (ecase unit-size
3268                (16
3269                 (setf (ioblock-write-char-when-locked-function ioblock)
3270                       '%ioblock-write-swapped-u16-encoded-char)
3271                 (case sharing
3272                   (:private '%private-ioblock-write-swapped-u16-encoded-char)
3273                   (:lock '%locked-ioblock-write-swapped-u16-encoded-char)
3274                   (t '%ioblock-write-swapped-u16-encoded-char))
3275                 (setf (ioblock-write-simple-string-function ioblock)
3276                       '%ioblock-write-swapped-u16-encoded-simple-string))
3277                (32
3278                 (setf (ioblock-write-char-when-locked-function ioblock)
3279                       '%ioblock-write-swapped-u32-encoded-char)
3280                 (case sharing
3281                   (:private '%private-ioblock-write-swapped-u32-encoded-char)
3282                   (:lock '%locked-ioblock-write-swapped-u32-encoded-char)
3283                   (t '%ioblock-write-swapped-u32-encoded-char))
3284                 (setf (ioblock-write-simple-string-function ioblock)
3285                       '%ioblock-write-swapped-u32-encoded-simple-string))))))))))
3286
3287
3288
3289;;; We can't define a MAKE-INSTANCE method on STRUCTURE-CLASS subclasses
3290;;; in MCL; of course, calling the structure-class's constructor does
3291;;; much the same thing (but note that MCL only keeps track of the
3292;;; default, automatically generated constructor.)
3293;;; (As fascinating as that may be, that has nothing to do with any
3294;;; nearby code, though it may have once been relevant.)
3295(defun make-ioblock-stream (class
3296                            &rest initargs
3297                            &key 
3298                            &allow-other-keys)
3299  (declare (dynamic-extent initargs))
3300  (let* ((s
3301          (if (subtypep class 'basic-stream)
3302            (apply #'make-basic-stream-instance class :allow-other-keys t initargs)
3303            (apply #'make-instance class :allow-other-keys t initargs))))
3304    (apply #'init-stream-ioblock s initargs)
3305    s))
3306
3307
3308
3309
3310
3311(defmethod select-stream-class ((s symbol) in-p out-p char-p)
3312  (select-stream-class (class-prototype (find-class s)) in-p out-p char-p))
3313
3314(defmethod select-stream-class ((s structure-class) in-p out-p char-p)
3315  (select-stream-class (class-prototype s) in-p out-p char-p))
3316
3317(defmethod select-stream-class ((s standard-class) in-p out-p char-p)
3318  (select-stream-class (class-prototype s) in-p out-p char-p))
3319
3320
3321(defparameter *canonical-line-termination-conventions*
3322  '((:unix . nil)
3323    (:macos . :cr)
3324    (:cr . :cr)
3325    (:crlf . :crlf)
3326    (:cp/m . :crlf)
3327    (:msdos . :crlf)
3328    (:dos . :crlf)
3329    (:windows . :crlf)
3330    (:inferred . nil)
3331    (:unicode . :unicode)))
3332
3333
3334(defun optimal-buffer-size (fd element-type)
3335  #+windows-target (declare (ignore fd))
3336  (let* (#-windows-target (nominal (or (nth-value 6 (%fstat fd)) *elements-per-buffer*))
3337         (octets #+windows-target #$BUFSIZ
3338                 #-windows-target
3339                 (case (%unix-fd-kind fd)
3340                   (:pipe (#_fpathconf fd #$_PC_PIPE_BUF))
3341                   (:socket
3342                    #+linux-target nominal
3343                    #-linux-target
3344                    (int-getsockopt fd #$SOL_SOCKET
3345                                    #+solaris-target #$SO_SNDBUF
3346                                    #-solaris-target #$SO_SNDLOWAT))
3347                   ((:character-special :tty) (#_fpathconf fd #$_PC_MAX_INPUT))
3348                   (t nominal))))
3349    (case (subtag-bytes (element-type-subtype element-type) 1)
3350      (1 octets)
3351      (2 (ash octets -1))
3352      (4 (ash octets -2))
3353      (8 (ash octets -3)))))
3354
3355
3356
3357
3358
3359(defun milliseconds-until-deadline (deadline ioblock)
3360  (let* ((now (get-internal-real-time)))
3361    (if (> now deadline)
3362      (error 'communication-deadline-expired :stream (ioblock-stream ioblock))
3363      (values (round (- deadline now) (/ internal-time-units-per-second 1000))))))
3364
3365
3366;;; Note that we can get "bivalent" streams by specifiying :character-p t
3367;;; with a reasonable element-type (e.g. (UNSIGNED-BYTE 8))
3368(defun make-fd-stream (fd &key
3369                          (direction :input)
3370                          (interactive t)
3371                          (element-type 'character)
3372                          (class 'fd-stream)
3373                          (sharing :private)
3374                          (character-p (or (eq element-type 'character)
3375                                           (subtypep element-type 'character)))
3376                          (basic nil)
3377                          encoding
3378                          line-termination
3379                          auto-close
3380                          input-timeout
3381                          output-timeout
3382                          deadline)
3383  (let* ((elements-per-buffer (optimal-buffer-size fd element-type)))
3384    (when line-termination
3385      (setq line-termination
3386            (cdr (assoc line-termination *canonical-line-termination-conventions*))))
3387    (when basic
3388      (setq class (map-to-basic-stream-class-name class))
3389      (setq basic (subtypep (find-class class) 'basic-stream)))
3390    (let* ((in-p (member direction '(:io :input)))
3391           (out-p (member direction '(:io :output)))
3392           (class-name (select-stream-class class in-p out-p character-p))
3393           (class (find-class class-name))
3394           (stream
3395            (make-ioblock-stream class
3396                                 :insize (if in-p elements-per-buffer)
3397                                 :outsize (if out-p elements-per-buffer)
3398                                 :device fd
3399                                 :interactive interactive
3400                                 :element-type element-type
3401                                 :advance-function (if in-p
3402                                                     (select-stream-advance-function class direction))
3403                                 :listen-function (if in-p 'fd-stream-listen)
3404                                 :eofp-function (if in-p 'fd-stream-eofp)
3405                                 :force-output-function (if out-p
3406                                                          (select-stream-force-output-function class direction))
3407                                 :close-function 'fd-stream-close
3408                                 :sharing sharing
3409                                 :character-p character-p
3410                                 :encoding encoding
3411                                 :line-termination line-termination
3412                                 :input-timeout input-timeout
3413                                 :output-timeout output-timeout
3414                                 :deadline deadline)))
3415      (if auto-close
3416        (terminate-when-unreachable stream
3417                                    (lambda (stream)
3418                                      (close-for-termination stream t))))
3419      stream)))
3420
3421 
3422;;;  Fundamental streams.
3423
3424(defclass fundamental-stream (stream)
3425    ())
3426
3427(defclass fundamental-input-stream (fundamental-stream input-stream)
3428    ((shared-resource :initform nil :accessor input-stream-shared-resource)))
3429
3430(defclass fundamental-output-stream (fundamental-stream output-stream)
3431    ())
3432
3433(defmethod input-stream-p ((x t))
3434  (report-bad-arg x 'stream))
3435                           
3436(defmethod input-stream-p ((s input-stream))
3437  t)
3438
3439(defmethod output-stream-p ((x t))
3440  (report-bad-arg x 'stream))
3441
3442(defmethod output-stream-p ((s input-stream))
3443  (typep s 'output-stream))
3444
3445(defmethod output-stream-p ((s output-stream))
3446  t)
3447
3448(defmethod input-stream-p ((s output-stream))
3449  (typep s 'input-stream))
3450
3451(defclass binary-stream (stream)
3452    ())
3453
3454(defclass character-stream (stream)
3455    ())
3456
3457(defmethod stream-external-format ((s character-stream))
3458  (make-external-format :character-encoding #+big-endian-target :utf-32be #+little-endian-target :utf-32le :line-termination :unix))
3459
3460
3461(defmethod (setf stream-external-format) (new (s character-stream))
3462  (check-type new external-format)
3463  (stream-external-format s))
3464
3465
3466(defclass fundamental-character-stream (fundamental-stream character-stream)
3467    ())
3468
3469(defmethod stream-element-type ((s fundamental-character-stream))
3470  'character)
3471
3472(defclass fundamental-binary-stream (fundamental-stream binary-stream)
3473    ())
3474
3475(defclass character-input-stream (input-stream character-stream)
3476    ())
3477
3478(defclass fundamental-character-input-stream (fundamental-input-stream
3479                                              fundamental-character-stream
3480                                              character-input-stream)
3481    ())
3482
3483(defmethod stream-read-char-no-hang ((s fundamental-character-input-stream))
3484  (stream-read-char s))
3485
3486(defmethod stream-peek-char ((s fundamental-character-input-stream))
3487  (let* ((ch (stream-read-char s)))
3488    (unless (eq ch :eof)
3489      (stream-unread-char s ch))
3490    ch))
3491
3492(defmethod stream-listen ((s fundamental-character-input-stream))
3493  (let* ((ch (stream-read-char-no-hang s)))
3494    (when (and ch (not (eq ch :eof)))
3495      (stream-unread-char s ch))
3496    ch))
3497
3498(defmethod stream-clear-input ((s fundamental-character-input-stream))
3499  )
3500
3501(defmethod stream-read-line ((s character-input-stream))
3502  (generic-read-line s))
3503
3504(defclass character-output-stream (output-stream character-stream)
3505    ())
3506
3507(defclass fundamental-character-output-stream (fundamental-output-stream
3508                                               fundamental-character-stream
3509                                               character-output-stream)
3510    ())
3511
3512(defclass binary-input-stream (input-stream binary-stream)
3513    ())
3514
3515(defclass fundamental-binary-input-stream (fundamental-input-stream
3516                                           fundamental-binary-stream
3517                                           binary-input-stream)
3518    ())
3519
3520(defclass binary-output-stream (output-stream binary-stream)
3521    ())
3522
3523(defclass fundamental-binary-output-stream (fundamental-output-stream
3524                                            fundamental-binary-stream
3525                                            binary-output-stream)
3526    ())
3527
3528
3529
3530(defmethod stream-read-byte ((s t))
3531  (report-bad-arg s '(and input-stream binary-stream)))
3532
3533(defmethod stream-write-byte ((s t) b)
3534  (declare (ignore b))
3535  (report-bad-arg s '(and output-stream binary-stream)))
3536
3537(defmethod stream-length ((s stream) &optional new)
3538  (declare (ignore new)))
3539
3540(defmethod stream-start-line-p ((s character-output-stream))
3541  (eql 0 (stream-line-column s)))
3542
3543(defmethod stream-terpri ((s character-output-stream))
3544  (stream-write-char s #\Newline))
3545
3546(defmethod stream-fresh-line ((s character-output-stream))
3547  (unless (stream-start-line-p s)
3548    (stream-terpri s)
3549    t))
3550
3551;;; The bad news is that this doesn't even bother to do the obvious
3552;;; (calling STREAM-WRITE-STRING with a longish string of spaces.)
3553;;; The good news is that this method is pretty useless to (format "~T" ...)
3554;;; anyhow.
3555(defmethod stream-advance-to-column ((s fundamental-character-output-stream)
3556                                     col)
3557  (generic-advance-to-column s col))
3558
3559(defmethod stream-write-string ((stream fundamental-character-output-stream) string &optional (start 0) end)
3560  (generic-stream-write-string stream string start end))
3561
3562
3563;;; The read-/write-vector methods could be specialized for stream classes
3564;;; that expose the underlying buffering mechanism.
3565;;; They can assume that the 'vector' argument is a simple one-dimensional
3566;;; array and that the 'start' and 'end' arguments are sane.
3567
3568(defmethod stream-write-vector ((stream character-output-stream)
3569                                vector start end)
3570  (declare (fixnum start end))
3571  (do* ((i start (1+ i)))
3572       ((= i end))
3573    (declare (fixnum i))
3574    (write-char (uvref vector i) stream)))
3575
3576(defmethod stream-write-vector ((stream binary-output-stream)
3577                                vector start end)
3578  (declare (fixnum start end))
3579  (do* ((i start (1+ i)))
3580       ((= i end))
3581    (declare (fixnum i))
3582    (write-byte (uvref vector i) stream)))
3583
3584(defmethod stream-read-vector ((stream character-input-stream)
3585                               vector start end)
3586  (generic-character-read-vector stream vector start end))
3587
3588
3589(defmethod stream-read-vector ((stream binary-input-stream)
3590                               vector start end)
3591  (declare (fixnum start end))
3592  (do* ((i start (1+ i)))
3593       ((= i end) end)
3594    (declare (fixnum i))
3595    (let* ((b (read-byte stream nil :eof)))
3596      (if (eq b :eof)
3597        (return i)
3598        (setf (uvref vector i) b)))))
3599
3600
3601
3602
3603;;; File streams, in the abstract.
3604
3605(defclass file-stream (stream)
3606    ())
3607
3608(defmethod stream-domain ((s file-stream))
3609  :file)
3610
3611
3612
3613;;; "Basic" (non-extensible) streams.
3614
3615
3616(declaim (inline basic-stream-p))
3617
3618(defun basic-stream-p (x)
3619  (= (the fixnum (typecode x)) target::subtag-basic-stream))
3620
3621(setf (type-predicate 'basic-stream) 'basic-stream-p)
3622
3623(make-built-in-class 'basic-stream 'stream)
3624(make-built-in-class 'basic-file-stream 'basic-stream 'file-stream)
3625(make-built-in-class 'basic-character-stream 'basic-stream 'character-stream)
3626(make-built-in-class 'basic-binary-stream 'basic-stream 'binary-stream)
3627
3628(make-built-in-class 'basic-input-stream 'basic-stream 'input-stream)
3629(make-built-in-class 'basic-output-stream 'basic-stream 'output-stream)
3630(make-built-in-class 'basic-io-stream 'basic-input-stream 'basic-output-stream)
3631(make-built-in-class 'basic-character-input-stream 'basic-input-stream 'basic-character-stream 'character-input-stream)
3632(make-built-in-class 'basic-character-output-stream 'basic-output-stream 'basic-character-stream 'character-output-stream)
3633(make-built-in-class 'basic-character-io-stream 'basic-character-input-stream 'basic-character-output-stream)
3634(make-built-in-class 'basic-binary-input-stream 'basic-input-stream 'basic-binary-stream 'binary-input-stream)
3635(make-built-in-class 'basic-binary-output-stream 'basic-output-stream 'basic-binary-stream 'binary-output-stream)
3636(make-built-in-class 'basic-binary-io-stream 'basic-binary-input-stream 'basic-binary-output-stream)
3637
3638
3639(defun %ioblock-external-format (ioblock)
3640  (let* ((encoding (or (ioblock-encoding ioblock)
3641                       (get-character-encoding nil)))
3642         (line-termination (or (ioblock-line-termination ioblock)
3643                               :unix)))
3644    (make-external-format :character-encoding (character-encoding-name encoding)
3645                          :line-termination line-termination)))
3646
3647(defmethod input-stream-shared-resource ((s basic-input-stream))
3648  (getf (basic-stream.info s) :shared-resource))
3649
3650(defmethod (setf input-stream-shared-resource) (new (s basic-input-stream))
3651  (setf (getf (basic-stream.info s) :shared-resource) new))
3652
3653(defmethod print-object ((s basic-stream) out)
3654  (print-unreadable-object (s out :type t :identity t)
3655    (let* ((ioblock (basic-stream.state s))
3656           (fd (and ioblock (ioblock-device ioblock)))
3657           (encoding (and ioblock (encoding-name (ioblock-encoding ioblock)))))
3658      (if fd
3659        (format out "~a (~a/~d)" encoding (%unix-fd-kind fd) fd)
3660        (format out "~s" :closed)))))
3661
3662(defmethod select-stream-class ((s (eql 'basic-stream)) in-p out-p char-p)
3663  (if char-p
3664    (if in-p
3665      (if out-p
3666        'basic-character-io-stream
3667        'basic-character-input-stream)
3668      'basic-character-output-stream)
3669    (if in-p
3670      (if out-p
3671        'basic-binary-io-stream
3672        'basic-binary-input-stream)
3673      'basic-binary-output-stream)))
3674
3675
3676(defmethod map-to-basic-stream-class-name (name)
3677  name)
3678
3679(defmethod map-to-basic-stream-class-name ((name (eql 'fd-stream)))
3680  'basic-stream)
3681
3682(defun allocate-basic-stream (class)
3683  (if (subtypep class 'basic-file-stream)
3684    (gvector :basic-stream (%class-own-wrapper class) 0 nil nil nil nil nil)
3685    (gvector :basic-stream (%class-own-wrapper class) 0 nil nil)))
3686
3687
3688(defmethod initialize-basic-stream ((s basic-stream) &key &allow-other-keys)
3689  )
3690 
3691(defmethod initialize-basic-stream :after  ((s basic-input-stream) &key &allow-other-keys)
3692  (setf (basic-stream.flags s)
3693        (logior (ash 1 basic-stream-flag.open-input) (basic-stream.flags s))))
3694
3695(defmethod initialize-basic-stream :after ((s basic-output-stream) &key &allow-other-keys)
3696  (setf (basic-stream.flags s)
3697        (logior (ash 1 basic-stream-flag.open-output) (basic-stream.flags s))))
3698
3699(defmethod initialize-basic-stream :after ((s basic-binary-stream) &key &allow-other-keys)
3700  (setf (basic-stream.flags s)
3701        (logior (ash 1 basic-stream-flag.open-binary) (basic-stream.flags s))))
3702
3703(defmethod initialize-basic-stream :after ((s basic-character-stream) &key &allow-other-keys)
3704  (setf (basic-stream.flags s)
3705        (logior (ash 1 basic-stream-flag.open-character) (basic-stream.flags s))))
3706
3707(defun make-basic-stream-instance (class &rest initargs)
3708  (let* ((s (allocate-basic-stream class)))
3709    (apply #'initialize-basic-stream s initargs)
3710    s))
3711
3712
3713
3714(defmethod (setf stream-ioblock) (ioblock (s basic-stream))
3715  (setf (basic-stream.state s) ioblock))
3716
3717(defmethod stream-create-ioblock ((stream basic-stream) &rest args &key)
3718  (declare (dynamic-extent args))
3719  (apply #'make-ioblock :stream stream args))
3720
3721
3722(defmethod stream-write-list ((stream fundamental-character-output-stream)
3723                              list count)
3724  (declare (fixnum count))
3725  (dotimes (i count)
3726    (stream-write-char stream (pop list))))
3727
3728(defmethod stream-write-list ((stream basic-character-output-stream)
3729                              list count)
3730  (declare (fixnum count))
3731  (dotimes (i count)
3732    (stream-write-char stream (pop list))))
3733
3734(defmethod stream-read-list ((stream character-input-stream)
3735                             list count)
3736  (generic-character-read-list stream list count))
3737
3738
3739(defmethod stream-write-list ((stream fundamental-binary-output-stream)
3740                              list count)
3741  (declare (fixnum count))
3742  (dotimes (i count)
3743    (let* ((element (pop list)))
3744      (if (typep element 'character)
3745        (write-char element stream)
3746        (write-byte element stream)))))
3747
3748(defmethod stream-write-list ((stream basic-binary-output-stream)
3749                              list count)
3750  (declare (fixnum count))
3751  (dotimes (i count)
3752    (let* ((element (pop list)))
3753      (if (typep element 'character)
3754        (write-char element stream)
3755        (write-byte element stream)))))
3756
3757(defmethod stream-read-list ((stream binary-input-stream)
3758                             list count)
3759  (declare (fixnum count))
3760  (do* ((tail list (cdr tail))
3761        (i 0 (1+ i)))
3762       ((= i count) count)
3763    (declare (fixnum i))
3764    (let* ((b (read-byte stream nil :eof)))
3765      (if (eq b :eof)
3766        (return i)
3767        (rplaca tail b)))))
3768
3769
3770
3771(defun stream-is-closed (s)
3772  (error "~s is closed" s))
3773
3774(defmethod stream-read-char ((s basic-character-input-stream))
3775  (let* ((ioblock (basic-stream-ioblock s)))
3776    (funcall (ioblock-read-char-function ioblock) ioblock)))
3777
3778
3779(defmethod stream-read-char-no-hang ((stream basic-character-input-stream))
3780  (let* ((ioblock (basic-stream-ioblock stream)))
3781    (with-ioblock-input-locked (ioblock)
3782      (values
3783          (%ioblock-tyi-no-hang ioblock)))))
3784       
3785(defmethod stream-peek-char ((stream basic-character-input-stream))
3786  (let* ((ioblock (basic-stream-ioblock stream)))
3787    (with-ioblock-input-locked (ioblock)
3788      (values
3789       (funcall (ioblock-peek-char-function ioblock) ioblock)))))
3790
3791(defmethod stream-clear-input ((stream basic-character-input-stream))
3792  (let* ((ioblock (basic-stream-ioblock stream)))
3793    (with-ioblock-input-locked (ioblock)
3794      (values
3795        (%ioblock-clear-input ioblock)))))
3796
3797(defmethod stream-unread-char ((s basic-character-input-stream) char)
3798  (let* ((ioblock (basic-stream-ioblock s)))
3799    (with-ioblock-input-locked (ioblock)
3800      (values
3801       (funcall (ioblock-unread-char-function ioblock) ioblock char)))))
3802
3803(defmethod stream-read-ivector ((s basic-binary-input-stream)
3804                                iv start nb)
3805  (let* ((ioblock (basic-stream-ioblock s)))
3806    (with-ioblock-input-locked (ioblock)
3807      (values
3808       (%ioblock-binary-in-ivect ioblock iv start nb)))))
3809
3810(defmethod stream-read-vector ((stream basic-character-input-stream)
3811                               vector start end)
3812  (declare (fixnum start end))
3813  (if (not (typep vector 'simple-base-string))
3814    (generic-character-read-vector stream vector start end)
3815    (let* ((ioblock (basic-stream-ioblock stream)))
3816      (with-ioblock-input-locked (ioblock)
3817        (values
3818         (funcall (ioblock-character-read-vector-function ioblock)
3819                  ioblock vector start end))))))
3820
3821(defmethod stream-read-line ((stream basic-character-input-stream))
3822  (let* ((ioblock (basic-stream-ioblock stream)))
3823    (with-ioblock-input-locked (ioblock)
3824      (funcall (ioblock-read-line-function ioblock) ioblock))))
3825
3826                             
3827;;; Synonym streams.
3828
3829(defclass synonym-stream (fundamental-stream)
3830    ((symbol :initarg :symbol :reader synonym-stream-symbol)))
3831
3832(defmethod print-object ((s synonym-stream) out)
3833  (print-unreadable-object (s out :type t :identity t)
3834    (format out "to ~s" (synonym-stream-symbol s))))
3835
3836(macrolet ((synonym-method (name &rest args)
3837            (let* ((stream (make-symbol "STREAM")))
3838              `(defmethod ,name ((,stream synonym-stream) ,@args)
3839                (,name (symbol-value (synonym-stream-symbol ,stream)) ,@args)))))
3840           (synonym-method stream-read-char)
3841           (synonym-method stream-read-byte)
3842           (synonym-method stream-unread-char c)
3843           (synonym-method stream-read-char-no-hang)
3844           (synonym-method stream-peek-char)
3845           (synonym-method stream-listen)
3846           (synonym-method stream-eofp)
3847           (synonym-method stream-clear-input)
3848           (synonym-method stream-read-line)
3849           (synonym-method stream-read-list l c)
3850           (synonym-method stream-read-vector v start end)
3851           (synonym-method stream-write-char c)
3852           ;(synonym-method stream-write-string str &optional (start 0) end)
3853           (synonym-method stream-write-byte b)
3854           (synonym-method stream-clear-output)
3855           (synonym-method stream-line-column)
3856           (synonym-method stream-line-length)
3857           (synonym-method stream-set-column new)
3858           (synonym-method stream-advance-to-column new)
3859           (synonym-method stream-start-line-p)
3860           (synonym-method stream-fresh-line)
3861           (synonym-method stream-terpri)
3862           (synonym-method stream-force-output)
3863           (synonym-method stream-finish-output)
3864           (synonym-method stream-write-list l c)
3865           (synonym-method stream-write-vector v start end)
3866           (synonym-method stream-element-type)
3867           (synonym-method input-stream-p)
3868           (synonym-method output-stream-p)
3869           (synonym-method interactive-stream-p)
3870           (synonym-method stream-direction)
3871           (synonym-method stream-device direction)
3872           (synonym-method stream-surrounding-characters)
3873           (synonym-method stream-input-timeout)
3874           (synonym-method stream-output-timeout)
3875           (synonym-method stream-deadline)
3876           (synonym-method stream-eof-transient-p))
3877
3878(defmethod (setf input-stream-timeout) (new (s synonym-stream))
3879  (setf (input-stream-timeout (symbol-value (synonym-stream-symbol s))) new))
3880
3881(defmethod (setf output-stream-timeout) (new (s synonym-stream))
3882  (setf (output-stream-timeout (symbol-value (synonym-stream-symbol s))) new))
3883
3884
3885(defmethod stream-write-string ((s synonym-stream) string &optional (start 0) end)
3886  (stream-write-string (symbol-value (synonym-stream-symbol s)) string start end))
3887
3888(defmethod stream-length ((s synonym-stream) &optional new)
3889  (stream-length (symbol-value (synonym-stream-symbol s)) new))
3890
3891(defmethod stream-position ((s synonym-stream) &optional new)
3892  (stream-position (symbol-value (synonym-stream-symbol s)) new))
3893
3894(defun make-synonym-stream (symbol)
3895  (make-instance 'synonym-stream :symbol (require-type symbol 'symbol)))
3896
3897;;;
3898(defclass composite-stream-mixin ()
3899    ((open-p :initform t)))
3900
3901(defmethod close :after ((stream composite-stream-mixin) &key abort)
3902  (declare (ignore abort))
3903  (with-slots (open-p) stream
3904    (setq open-p nil)))
3905
3906(defmethod open-stream-p ((stream composite-stream-mixin))
3907  (slot-value stream 'open-p))
3908
3909
3910;;; Two-way streams.
3911(defclass two-way-stream (composite-stream-mixin fundamental-input-stream fundamental-output-stream)
3912    ((input-stream :initarg :input-stream :accessor two-way-stream-input-stream)
3913     (output-stream :initarg :output-stream :accessor two-way-stream-output-stream)))
3914
3915(defmethod stream-eof-transient-p ((stream two-way-stream))
3916  (stream-eof-transient-p (two-way-stream-input-stream stream)))
3917
3918(defmethod print-object ((s two-way-stream) out)
3919  (print-unreadable-object (s out :type t :identity t)
3920    (format out "input ~s, output ~s" 
3921            (two-way-stream-input-stream s)
3922            (two-way-stream-output-stream s))))
3923
3924(macrolet ((two-way-input-method (name &rest args)
3925             (let* ((stream (make-symbol "STREAM")))
3926               `(defmethod ,name ((,stream two-way-stream) ,@args)
3927                 (,name (two-way-stream-input-stream ,stream) ,@args))))
3928           (two-way-output-method (name &rest args)
3929             (let* ((stream (make-symbol "STREAM")))
3930               `(defmethod ,name ((,stream two-way-stream) ,@args)
3931                 (,name (two-way-stream-output-stream ,stream) ,@args)))))
3932  (two-way-input-method stream-read-char)
3933  (two-way-input-method stream-read-byte)
3934  (two-way-input-method stream-unread-char c)
3935  (two-way-input-method stream-read-char-no-hang)
3936  (two-way-input-method stream-peek-char)
3937  (two-way-input-method stream-listen)
3938  (two-way-input-method stream-eofp)
3939  (two-way-input-method stream-clear-input)
3940  (two-way-input-method stream-read-line)
3941  (two-way-input-method stream-read-list l c)
3942  (two-way-input-method stream-read-vector v start end)
3943  (two-way-input-method stream-surrounding-characters)
3944  (two-way-input-method stream-input-timeout)
3945  (two-way-input-method interactive-stream-p)
3946  (two-way-output-method stream-write-char c)
3947  (two-way-output-method stream-write-byte b)
3948  (two-way-output-method stream-clear-output)
3949  (two-way-output-method stream-line-column)
3950  (two-way-output-method stream-line-length)
3951  (two-way-output-method stream-set-column new)
3952  (two-way-output-method stream-advance-to-column new)
3953  (two-way-output-method stream-start-line-p)
3954  (two-way-output-method stream-fresh-line)
3955  (two-way-output-method stream-terpri)
3956  (two-way-output-method stream-force-output)
3957  (two-way-output-method stream-finish-output)
3958  (two-way-output-method stream-write-list l c)
3959  (two-way-output-method stream-write-vector v start end)
3960  (two-way-output-method stream-output-timeout)
3961  (two-way-output-method stream-deadline))
3962
3963(defmethod (setf stream-input-timeout) (new (s two-way-stream))
3964  (setf (stream-input-timeout (two-way-stream-input-stream s)) new))
3965
3966(defmethod (setf stream-output-timeout) (new (s two-way-stream))
3967  (setf (stream-output-timeout (two-way-stream-output-stream s)) new))
3968
3969(defmethod (setf stream-deadline) (new (s two-way-stream))
3970  (setf (stream-deadline (two-way-stream-output-stream s)) new))
3971
3972(defmethod stream-device ((s two-way-stream) direction)
3973  (case direction
3974    (:input (stream-device (two-way-stream-input-stream s) direction))
3975    (:output (stream-device (two-way-stream-output-stream s) direction))))
3976   
3977(defmethod stream-write-string ((s two-way-stream) string &optional (start 0) end)
3978  (stream-write-string (two-way-stream-output-stream s) string start end))
3979
3980(defmethod stream-element-type ((s two-way-stream))
3981  (let* ((in-type (stream-element-type (two-way-stream-input-stream s)))
3982         (out-type (stream-element-type (two-way-stream-output-stream s))))
3983    (if (equal in-type out-type)
3984      in-type
3985      `(and ,in-type ,out-type))))
3986
3987(defun make-two-way-stream (in out)
3988  "Return a bidirectional stream which gets its input from INPUT-STREAM and
3989   sends its output to OUTPUT-STREAM."
3990  (unless (input-stream-p in)
3991    (require-type in 'input-stream))
3992  (unless (output-stream-p out)
3993    (require-type out 'output-stream))
3994  (make-instance 'two-way-stream :input-stream in :output-stream out))
3995
3996;;; This is intended for use with things like *TERMINAL-IO*, where the
3997;;; OS echoes interactive input.  Whenever we read a character from
3998;;; the underlying input-stream of such a stream, we need to update
3999;;; our notion of the underlying output-stream's STREAM-LINE-COLUMN.
4000
4001(defclass echoing-two-way-stream (two-way-stream)
4002    ())
4003
4004(defmethod stream-read-char ((s echoing-two-way-stream))
4005  (let* ((out (two-way-stream-output-stream s))
4006         (in (two-way-stream-input-stream s)))
4007    (force-output out)
4008    (let* ((ch (stream-read-char in)))
4009      (unless (eq ch :eof)
4010        (if (eq ch #\newline)
4011          (stream-set-column out 0)
4012          (let* ((cur (stream-line-column out)))
4013            (when cur
4014              (stream-set-column out (1+ (the fixnum cur)))))))
4015      ch)))
4016
4017(defmethod stream-read-line ((s echoing-two-way-stream))
4018  (let* ((out (two-way-stream-output-stream s)))
4019    (force-output out)
4020    (multiple-value-bind (string eof)
4021        (call-next-method)
4022      (unless eof
4023        (stream-set-column out 0))
4024      (values string eof))))
4025
4026(defun make-echoing-two-way-stream (in out)
4027  (make-instance 'echoing-two-way-stream :input-stream in :output-stream out))
4028
4029;;;echo streams
4030
4031(defclass echo-stream (two-way-stream)
4032    ((did-untyi :initform nil)))
4033
4034(defmethod echo-stream-input-stream ((s echo-stream))
4035  (two-way-stream-input-stream s))
4036
4037(defmethod echo-stream-output-stream ((s echo-stream))
4038  (two-way-stream-output-stream s))
4039
4040(defmethod stream-read-char ((s echo-stream))
4041  (let* ((char (stream-read-char (echo-stream-input-stream s))))
4042    (unless (eq char :eof)
4043      (if (slot-value s 'did-untyi)
4044        (setf (slot-value s 'did-untyi) nil)
4045        (stream-write-char (echo-stream-output-stream s) char)))
4046    char))
4047
4048(defmethod stream-unread-char ((s echo-stream) c)
4049  (call-next-method s c)
4050  (setf (slot-value s 'did-untyi) c))
4051
4052(defmethod stream-read-char-no-hang ((s echo-stream))
4053  (let* ((char (stream-read-char-no-hang (echo-stream-input-stream s))))
4054    (unless (eq char :eof)
4055      (if (slot-value s 'did-untyi)
4056        (setf (slot-value s 'did-untyi) nil)
4057        (stream-write-char (echo-stream-output-stream s) char)))
4058    char))
4059
4060(defmethod stream-clear-input ((s echo-stream))
4061  (call-next-method)
4062  (setf (slot-value s 'did-untyi) nil))
4063
4064(defmethod stream-read-byte ((s echo-stream))
4065  (let* ((byte (stream-read-byte (echo-stream-input-stream s))))
4066    (unless (eq byte :eof)
4067      (stream-write-byte (echo-stream-output-stream s) byte))
4068    byte))
4069
4070(defmethod stream-read-line ((s echo-stream))
4071  (generic-read-line s))
4072
4073(defmethod stream-read-vector ((s echo-stream) vector start end)
4074  (if (subtypep (stream-element-type s) 'character)
4075      (generic-character-read-vector s vector start end)
4076    (generic-binary-read-vector s vector start end)))
4077
4078(defun make-echo-stream (input-stream output-stream)
4079  "Return a bidirectional stream which gets its input from INPUT-STREAM and
4080   sends its output to OUTPUT-STREAM. In addition, all input is echoed to
4081   the output stream."
4082  (make-instance 'echo-stream
4083                 :input-stream input-stream
4084                 :output-stream output-stream))
4085
4086;;;concatenated-streams
4087
4088(defclass concatenated-stream (composite-stream-mixin fundamental-input-stream)
4089    ((streams :initarg :streams :accessor concatenated-stream-streams)))
4090
4091
4092(defun concatenated-stream-current-input-stream (s)
4093  (car (concatenated-stream-streams s)))
4094
4095(defun concatenated-stream-next-input-stream (s)
4096  (setf (concatenated-stream-streams s)
4097        (cdr (concatenated-stream-streams s)))
4098  (concatenated-stream-current-input-stream s))
4099
4100(defmethod stream-element-type ((s concatenated-stream))
4101  (let* ((c (concatenated-stream-current-input-stream s)))
4102    (if c
4103      (stream-element-type c)
4104      nil)))
4105
4106
4107
4108(defmethod stream-read-char ((s concatenated-stream))
4109  (do* ((c (concatenated-stream-current-input-stream s)
4110           (concatenated-stream-next-input-stream s)))
4111       ((null c) :eof)
4112    (let* ((ch (stream-read-char c)))
4113      (unless (eq ch :eof)
4114        (return ch)))))
4115
4116(defmethod stream-read-char-no-hang ((s concatenated-stream))
4117  (do* ((c (concatenated-stream-current-input-stream s)
4118           (concatenated-stream-next-input-stream s)))
4119       ((null c) :eof)
4120    (let* ((ch (stream-read-char-no-hang c)))
4121      (unless (eq ch :eof)
4122        (return ch)))))
4123
4124(defmethod stream-read-byte ((s concatenated-stream))
4125  (do* ((c (concatenated-stream-current-input-stream s)
4126           (concatenated-stream-next-input-stream s)))
4127       ((null c) :eof)
4128    (let* ((b (stream-read-byte c)))
4129      (unless (eq b :eof)
4130        (return b)))))
4131
4132(defmethod stream-peek-char ((s concatenated-stream))
4133  (do* ((c (concatenated-stream-current-input-stream s)
4134       (concatenated-stream-next-input-stream s)))
4135       ((null c) :eof)
4136    (let* ((ch (stream-peek-char c)))
4137      (unless (eq ch :eof)
4138        (return ch)))))
4139
4140(defmethod stream-read-line ((s concatenated-stream))
4141  (generic-read-line s))
4142
4143(defmethod stream-read-list ((s concatenated-stream) list count)
4144  (generic-character-read-list s list count))
4145
4146(defmethod stream-read-vector ((s concatenated-stream) vector start end)
4147  (if (subtypep (stream-element-type s) 'character)
4148      (generic-character-read-vector s vector start end)
4149    (generic-binary-read-vector s vector start end)))
4150
4151(defmethod stream-unread-char ((s concatenated-stream) char)
4152  (let* ((c (concatenated-stream-current-input-stream s)))
4153    (if c
4154      (stream-unread-char c char))))
4155
4156(defmethod stream-listen ((s concatenated-stream))
4157  (do* ((c (concatenated-stream-current-input-stream s)
4158           (concatenated-stream-next-input-stream s)))
4159       ((null c))
4160    (when (stream-listen c)
4161      (return t))))
4162
4163(defmethod stream-eofp ((s concatenated-stream))
4164  (do* ((c (concatenated-stream-current-input-stream s)
4165           (concatenated-stream-next-input-stream s)))
4166       ((null c) t)
4167    (when (stream-listen c)
4168      (return nil))))
4169
4170(defmethod stream-clear-input ((s concatenated-stream))
4171  (let* ((c (concatenated-stream-current-input-stream s)))
4172    (when c (stream-clear-input c))))
4173
4174
4175(defun make-concatenated-stream (&rest streams)
4176  "Return a stream which takes its input from each of the streams in turn,
4177   going on to the next at EOF."
4178  (dolist (s streams (make-instance 'concatenated-stream :streams streams))
4179    (unless (input-stream-p s)
4180      (error "~S is not an input stream" s))))
4181
4182;;;broadcast-streams
4183
4184
4185
4186(defclass broadcast-stream (fundamental-output-stream)
4187    ((streams :initarg :streams :reader broadcast-stream-streams)))
4188
4189(macrolet ((broadcast-method
4190               (op (stream &rest others )
4191                   &optional
4192                   (args (cons stream others)))
4193             (let* ((sub (gensym))
4194                    (result (gensym)))
4195               `(defmethod ,op ((,stream broadcast-stream) ,@others)
4196                 (let* ((,result nil))
4197                   (dolist (,sub (broadcast-stream-streams ,stream) ,result)
4198                             (setq ,result (,op ,@(cons sub (cdr args))))))))))
4199             (broadcast-method stream-write-char (s c))
4200             (broadcast-method stream-write-string
4201                                      (s str &optional (start 0) end)
4202                                      (s str start end))
4203             (broadcast-method stream-write-byte (s b))
4204             (broadcast-method stream-clear-output (s))
4205             (broadcast-method stream-line-column (s))
4206             (broadcast-method stream-set-column (s new))
4207             (broadcast-method stream-advance-to-column (s new))
4208             (broadcast-method stream-start-line-p (s))
4209             (broadcast-method stream-terpri (s))
4210             (broadcast-method stream-force-output (s))
4211             (broadcast-method stream-finish-output (s))
4212             (broadcast-method stream-write-list (s l c))
4213             (broadcast-method stream-write-vector (s v start end)))
4214
4215(defun last-broadcast-stream (s)
4216  (car (last (broadcast-stream-streams s))))
4217
4218(defmethod stream-fresh-line ((s broadcast-stream))
4219  (let* ((did-output-newline nil))
4220    (dolist (sub (broadcast-stream-streams s) did-output-newline)
4221      (setq did-output-newline (stream-fresh-line sub)))))
4222
4223(defmethod stream-element-type ((s broadcast-stream))
4224  (let* ((last (last-broadcast-stream s)))
4225    (if last
4226      (stream-element-type last)
4227      t)))
4228
4229(defmethod stream-length ((s broadcast-stream) &optional new)
4230  (unless new
4231    (let* ((last (last-broadcast-stream s)))
4232      (if last
4233        (stream-length last)
4234        0))))
4235
4236(defmethod stream-position ((s broadcast-stream) &optional new)
4237  (unless new
4238    (let* ((last (last-broadcast-stream s)))
4239      (if last
4240        (stream-position last)
4241        0))))
4242
4243(defun make-broadcast-stream (&rest streams)
4244  (dolist (s streams (make-instance 'broadcast-stream :streams streams))
4245    (unless (output-stream-p s)
4246      (report-bad-arg s '(satisfies output-stream-p)))))
4247
4248
4249
4250;;; String streams.
4251(make-built-in-class 'string-stream 'basic-character-stream)
4252
4253(defmethod print-object ((s string-stream) out)
4254  (print-unreadable-object (s out :type t :identity t)
4255    (unless (open-stream-p s)  (format out " ~s" :closed))))
4256
4257
4258                 
4259
4260(defstruct (string-stream-ioblock (:include ioblock))
4261  string)
4262
4263(defstruct (string-output-stream-ioblock (:include string-stream-ioblock))
4264  (index 0)
4265  freelist
4266  (line-length 80))
4267
4268(defstatic *string-output-stream-class* (make-built-in-class 'string-output-stream 'string-stream 'basic-character-output-stream))
4269(defstatic *string-output-stream-class-wrapper* (%class-own-wrapper *string-output-stream-class*))
4270
4271(defstatic *fill-pointer-string-output-stream-class* (make-built-in-class 'fill-pointer-string-output-stream 'string-output-stream))
4272
4273(def-standard-initial-binding %string-output-stream-ioblocks% (%cons-pool nil))
4274
4275(defmethod stream-force-output ((s string-output-stream))
4276  nil)
4277
4278(defmethod stream-finish-output ((s string-output-stream))
4279  nil)
4280
4281(defmethod stream-clear-output ((s string-output-stream))
4282  nil)
4283
4284(defmethod stream-line-length ((s string-output-stream))
4285  (let* ((ioblock (basic-stream-ioblock s)))
4286    (string-output-stream-ioblock-line-length ioblock)))
4287
4288(defmethod (setf stream-line-length) (newlen (s string-output-stream))
4289  (let* ((ioblock (basic-stream-ioblock s)))
4290    (setf (string-output-stream-ioblock-line-length ioblock) newlen)))
4291
4292
4293;;; Should only be used for a stream whose class is exactly
4294;;; *string-output-stream-class*
4295(defun %close-string-output-stream (stream ioblock)
4296  (let* ((pool %string-output-stream-ioblocks%))
4297    (when (and pool
4298               (eq (basic-stream.wrapper stream)
4299                   *string-output-stream-class-wrapper*)
4300               (eq (string-output-stream-ioblock-freelist ioblock) pool))
4301      (without-interrupts
4302       (setf (ioblock-stream ioblock) (pool.data pool)
4303             (pool.data pool) ioblock)))))
4304
4305;;; If this is the sort of string stream whose ioblock we recycle and
4306;;; there's a thread-local binding of the variable we use for a freelist,
4307;;; return the value of that binding.
4308(defun %string-stream-ioblock-freelist (stream)
4309  (and stream
4310       (eq (basic-stream.wrapper stream)
4311           *string-output-stream-class-wrapper*)
4312       (let* ((loc (%tcr-binding-location (%current-tcr) '%string-output-stream-ioblocks%)))
4313         (and loc (%fixnum-ref loc)))))
4314
4315
4316(defun create-string-output-stream-ioblock (stream string write-char-function write-string-function)
4317  (let* ((recycled (and stream
4318                        (eq (basic-stream.wrapper stream)
4319                            *string-output-stream-class-wrapper*)
4320                        (without-interrupts
4321                         (let* ((data (pool.data %string-output-stream-ioblocks%)))
4322                           (when data
4323                             (setf (pool.data %string-output-stream-ioblocks%)
4324                                   (ioblock-stream data)
4325                                   (ioblock-stream data) stream
4326                                   (ioblock-device data) -1
4327                                   (ioblock-charpos data) 0
4328                                   (string-output-stream-ioblock-index data) 0
4329                                   (string-output-stream-ioblock-line-length data) 80))
4330                           data)))))
4331    (or recycled
4332        (make-string-output-stream-ioblock :stream stream
4333                                           :string string
4334                                           :element-type 'character
4335                                           :write-char-function write-char-function
4336                                           :write-char-when-locked-function write-char-function
4337                                           :write-simple-string-function write-string-function
4338                                           :force-output-function #'false
4339                                           :freelist (%string-stream-ioblock-freelist stream)
4340                                           :close-function #'%close-string-output-stream
4341                                           :device -1))))
4342                       
4343
4344
4345(defun %%make-string-output-stream (class string write-char-function write-string-function)
4346  (let* ((stream (gvector :basic-stream (%class.own-wrapper class)
4347                          (logior (ash 1 basic-stream-flag.open-character)
4348                                  (ash 1 basic-stream-flag.open-output))
4349                          nil
4350                          nil))
4351         (ioblock (create-string-output-stream-ioblock stream string write-char-function write-string-function)))
4352      (setf (basic-stream.state stream) ioblock)
4353      stream))
4354
4355(declaim (inline %string-push-extend))
4356(defun %string-push-extend (char string)
4357  (let* ((fill (%svref string target::vectorH.logsize-cell))
4358         (size (%svref string target::vectorH.physsize-cell)))
4359    (declare (fixnum fill size))
4360    (if (< fill size)
4361      (multiple-value-bind (data offset) (array-data-and-offset string)
4362        (declare (simple-string data) (fixnum offset))
4363        (setf (schar data (the fixnum (+ offset fill))) char
4364              (%svref string target::vectorH.logsize-cell) (the fixnum (1+ fill))))
4365      (vector-push-extend char string))))
4366             
4367
4368(defun fill-pointer-string-output-stream-ioblock-write-char (ioblock char)
4369  ;; can do better (maybe much better) than VECTOR-PUSH-EXTEND here.
4370  (if (eql char #\Newline)
4371    (setf (ioblock-charpos ioblock) 0)
4372    (incf (ioblock-charpos ioblock)))
4373  (%string-push-extend char (string-stream-ioblock-string ioblock)))
4374
4375(defun fill-pointer-string-output-stream-ioblock-write-simple-string (ioblock string start-char num-chars)
4376  (let* ((end (+ start-char num-chars))
4377         (nlpos (position #\Newline string :start start-char :end end :from-end t)))
4378    (if nlpos
4379      (setf (ioblock-charpos ioblock) (- end nlpos))
4380      (incf (ioblock-charpos ioblock) num-chars))
4381    (let* ((out (string-stream-ioblock-string ioblock)))
4382      (do* ((n 0 (1+ n))
4383            (i start-char (1+ i)))
4384           ((= n num-chars) num-chars)
4385        (%string-push-extend (schar string i) out)))))
4386
4387(defmethod stream-position ((s fill-pointer-string-output-stream) &optional newpos)
4388  (let* ((string (string-stream-string s)))
4389    (if newpos
4390      (setf (fill-pointer string) newpos)
4391      (fill-pointer string))))
4392
4393;;; If the stream's string is adjustable, it doesn't really have a meaningful
4394;;; "maximum size".
4395(defmethod stream-length ((s string-output-stream) &optional newlen)
4396  (unless newlen
4397    (array-total-size (string-stream-string s))))
4398
4399;;; This creates a FILL-POINTER-STRING-OUTPUT-STREAM.
4400(defun %make-string-output-stream (string)
4401  (unless (and (typep string 'string)
4402               (array-has-fill-pointer-p string))
4403    (error "~S must be a string with a fill pointer." string))
4404  (%%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))
4405
4406(defun string-output-stream-ioblock-write-char (ioblock char)
4407  (let* ((string (string-output-stream-ioblock-string ioblock))
4408         (index (string-output-stream-ioblock-index ioblock))
4409         (len (length string)))
4410    (declare (simple-string string)
4411             (fixnum index len))
4412  (if (eql char #\Newline)
4413    (setf (ioblock-charpos ioblock) 0)
4414    (incf (ioblock-charpos ioblock)))
4415  (if (= index len)
4416      (let* ((newlen (if (zerop len) 20 (+ len len)))      ;non-zero !
4417             (new (make-string newlen)))
4418        (%copy-ivector-to-ivector string 0 new 0 (the fixnum (ash len 2)))
4419        (setq string new)
4420        (setf (string-output-stream-ioblock-string ioblock) new)))
4421    (setf (string-output-stream-ioblock-index ioblock) (the fixnum (1+ index))
4422          (schar string index) char)))
4423
4424(defun string-output-stream-ioblock-write-simple-string (ioblock string start-char num-chars)
4425  (declare (simple-string string)
4426           (fixnum start-char num-chars)
4427           (optimize (speed 3) (safety 0)))
4428  (let* ((out (string-output-stream-ioblock-string ioblock))
4429         (index (string-output-stream-ioblock-index ioblock))
4430         (len (length out))
4431         (need (+ index num-chars)))
4432    (declare (simple-string out)
4433             (fixnum index len need))
4434    (if (< len need)
4435      (let* ((newlen (+