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

Last change on this file since 15265 was 15177, checked in by gb, 8 years ago

New! Improved! Properly parenthesized!

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