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

Last change on this file since 15292 was 15292, checked in by gb, 7 years ago

%ioblock-peek-char (the ISO-8859-1 version): if we don't get EOF,
we can safely decrement the input buffer idx by 1 (it'll always be

1 after reading an octet.)

%encoded-ioblock-peek-char: (all other encodings): let the ioblock's
unread-char function decide how to handle unreading the character.
(FILE-STREAMs generally adjust the file's position, other kinds
of streams use IOBLOCK-UNTYI-CHAR, which confuses FILE-POSITION on
FILE-STREAMs.)

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 256.6 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 1994-2001 Digitool, Inc
4;;;   Portions copyright (C) 2001-2009 Clozure Associates
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18(in-package "CCL")
19
20;;;
21
22(defclass stream ()
23  ())
24
25
26(defclass input-stream (stream)
27  ())
28
29
30(defclass output-stream (stream) ())
31
32(defmethod stream-direction ((s stream))
33  )
34
35(defmethod stream-domain ((s stream))
36  t)
37
38
39(defmethod stream-direction ((s input-stream))
40  (if (typep s 'output-stream)
41    :io
42    :input))
43
44(defmethod stream-direction ((s output-stream))
45  (if (typep s 'input-stream)
46    :io
47    :output))
48
49(defun check-io-timeout (timeout)
50  (when timeout
51    (require-type timeout '(real 0 1000000))))
52
53(defmethod stream-input-timeout ((s input-stream))
54  nil)
55
56(defmethod (setf input-stream-timeout) (new (s input-stream))
57  (check-io-timeout new))
58
59(defmethod stream-output-timeout ((s output-stream))
60  nil)
61
62(defmethod (setf stream-output-timeout) (new (s output-stream))
63  (check-io-timeout new))
64
65;;; Try to return a string containing characters that're near the
66;;; stream's current position, if that makes sense.  Return NIL
67;;; if it doesn't make sense.
68;;; Some things (SOCKET-ERRORs) are signaled as STREAM-ERRORs
69;;; whose STREAM args aren't streams.  That's wrong, but
70;;; defining this method on T keeps things from blowing up worse.
71(defmethod stream-surrounding-characters ((s t))
72  (declare (ignore s))
73  nil)
74
75
76;;; The "direction" argument only helps us dispatch on two-way streams:
77;;; it's legal to ask for the :output device of a stream that's only open
78;;; for input, and one might get a non-null answer in that case.
79(defmethod stream-device ((s stream) direction)
80  (declare (ignore direction)))
81
82;;; Some generic stream functions:
83(defmethod stream-length ((x t) &optional new)
84  (declare (ignore new))
85  (report-bad-arg x 'stream))
86
87(defmethod stream-position ((x t) &optional new)
88  (declare (ignore new))
89  (report-bad-arg x 'stream))
90
91(defmethod stream-element-type ((x t))
92  (report-bad-arg x 'stream))
93
94(defmethod stream-force-output ((x t))
95  (report-bad-arg x 'stream))
96
97(defmethod stream-position ((s stream) &optional newpos)
98  (declare (ignore newpos)))
99
100;;; For input streams:
101
102;;; From Shannon Spires, slightly modified.
103(defun generic-read-line (s)
104  (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* ((b (%ioblock-read-u8-byte ioblock)))
1379        (if (eq b :eof)
1380          b
1381          (let* ((ch (%code-char b))
1382                 (buf (ioblock-inbuf ioblock))
1383                 (idx (io-buffer-idx buf)))
1384            (declare (fixnum idx))
1385            (setf (io-buffer-idx buf) (the fixnum (1- idx)))
1386            ch)))))
1387
1388(defun %encoded-ioblock-peek-char (ioblock)
1389  (or (ioblock-untyi-char ioblock)
1390      (let* ((ch (funcall (ioblock-read-char-when-locked-function ioblock) ioblock)))
1391        (unless (eq ch :eof)
1392          (funcall (ioblock-unread-char-function ioblock) ioblock ch))
1393        ch)))
1394
1395
1396
1397
1398(defun %ioblock-clear-input (ioblock)   
1399    (let* ((buf (ioblock-inbuf ioblock)))
1400      (setf (io-buffer-count buf) 0
1401            (io-buffer-idx buf) 0
1402            (ioblock-untyi-char ioblock) nil)))
1403
1404(defun %ioblock-untyi (ioblock char)
1405  (if (ioblock-untyi-char ioblock)
1406    (error "Two UNREAD-CHARs without intervening READ-CHAR on ~s"
1407           (ioblock-stream ioblock))
1408    (setf (ioblock-untyi-char ioblock) char)))
1409
1410(declaim (inline ioblock-inpos))
1411
1412(defun ioblock-inpos (ioblock)
1413  (io-buffer-idx (ioblock-inbuf ioblock)))
1414
1415(declaim (inline ioblock-outpos))
1416
1417(defun ioblock-outpos (ioblock)
1418  (io-buffer-count (ioblock-outbuf ioblock)))
1419
1420
1421
1422(declaim (inline %ioblock-force-output))
1423
1424(defun %ioblock-force-output (ioblock finish-p)
1425  (funcall (ioblock-force-output-function ioblock)
1426           (ioblock-stream ioblock)
1427           ioblock
1428           (ioblock-outpos ioblock)
1429           finish-p))
1430
1431;;; ivector should be an ivector.  The ioblock should have an
1432;;; element-shift of 0; start-octet and num-octets should of course
1433;;; be sane.  This is mostly to give the fasdumper a quick way to
1434;;; write immediate data.
1435(defun %ioblock-out-ivect (ioblock ivector start-octet num-octets)
1436  (unless (= 0 (the fixnum (ioblock-element-shift ioblock)))
1437    (error "Can't write vector to stream ~s" (ioblock-stream ioblock)))
1438  (let* ((written 0)
1439         (out (ioblock-outbuf ioblock)))
1440    (declare (fixnum written))
1441    (do* ((pos start-octet (+ pos written))
1442          (left num-octets (- left written)))
1443         ((= left 0) num-octets)
1444      (declare (fixnum pos left))
1445      (setf (ioblock-dirty ioblock) t)
1446      (let* ((index (io-buffer-idx out))
1447             (count (io-buffer-count out))
1448             (bufsize (io-buffer-size out))
1449             (avail (- bufsize index))
1450             (buffer (io-buffer-buffer out)))
1451        (declare (fixnum index avail count bufsize))
1452        (cond
1453          ((= (setq written avail) 0)
1454           (%ioblock-force-output ioblock nil))
1455          (t
1456           (if (> written left)
1457             (setq written left))
1458           (%copy-ivector-to-ivector ivector pos buffer index written)
1459           (setf (ioblock-dirty ioblock) t)
1460           (incf index written)
1461           (if (> index count)
1462             (setf (io-buffer-count out) index))
1463           (setf (io-buffer-idx out) index)
1464           (if (= index  bufsize)
1465             (%ioblock-force-output ioblock nil))))))))
1466
1467
1468(defun %ioblock-unencoded-write-simple-string (ioblock string start-char num-chars)
1469  (declare (fixnum start-char num-chars) (simple-string string))
1470  (let* ((written 0)
1471         (col (ioblock-charpos ioblock))
1472         (out (ioblock-outbuf ioblock)))
1473    (declare (fixnum written col)
1474             (optimize (speed 3) (safety 0)))
1475    (do* ((pos start-char (+ pos written))
1476          (left num-chars (- left written)))
1477         ((= left 0) (setf (ioblock-charpos ioblock) col)  num-chars)
1478      (declare (fixnum pos left))
1479      (setf (ioblock-dirty ioblock) t)
1480      (let* ((index (io-buffer-idx out))
1481             (count (io-buffer-count out))
1482             (bufsize (io-buffer-size out))
1483             (buffer (io-buffer-buffer out))
1484             (avail (- bufsize index)))
1485        (declare (fixnum index bufsize avail count)
1486                 (type (simple-array (unsigned-byte 8) (*)) buffer))
1487        (cond
1488          ((= (setq written avail) 0)
1489           (%ioblock-force-output ioblock nil))
1490          (t
1491           (if (> written left)
1492             (setq written left))
1493           (do* ((p pos (1+ p))
1494                 (i index (1+ i))
1495                 (j 0 (1+ j)))
1496                ((= j written))
1497             (declare (fixnum p i j))
1498             (let* ((ch (schar string p))
1499                    (code (char-code ch)))
1500               (declare (type (mod #x110000) code))
1501               (if (eql ch #\newline)
1502                 (setq col 0)
1503                 (incf col))
1504               (setf (aref buffer i) (if (>= code 256) (char-code #\Sub) code))))
1505           (setf (ioblock-dirty ioblock) t)
1506           (incf index written)
1507           (if (> index count)
1508             (setf (io-buffer-count out) index))
1509           (setf (io-buffer-idx out) index)
1510           (if (= index  bufsize)
1511             (%ioblock-force-output ioblock nil))))))))
1512
1513
1514
1515(defun %ioblock-eofp (ioblock)
1516  (let* ((buf (ioblock-inbuf ioblock)))
1517   (and (eql (io-buffer-idx buf)
1518             (io-buffer-count buf))
1519         (locally (declare (optimize (speed 3) (safety 0)))
1520           (with-ioblock-input-locked (ioblock)
1521             (funcall (ioblock-eofp-function ioblock)
1522                      (ioblock-stream ioblock)
1523                      ioblock))))))
1524
1525(defun %ioblock-listen (ioblock)
1526  (let* ((buf (ioblock-inbuf ioblock)))
1527    (or (< (the fixnum (io-buffer-idx buf))
1528           (the fixnum (io-buffer-count buf)))
1529        (funcall (ioblock-listen-function ioblock)
1530                 (ioblock-stream ioblock)
1531                 ioblock))))
1532
1533
1534
1535(declaim (inline %ioblock-write-u8-element))
1536(defun %ioblock-write-u8-element (ioblock element)
1537  (declare (optimize (speed 3) (safety 0)))
1538  (let* ((buf (ioblock-outbuf ioblock))
1539         (idx (io-buffer-idx buf))
1540         (count (io-buffer-count buf))
1541         (limit (io-buffer-limit buf)))
1542    (declare (fixnum idx limit count))
1543    (when (= idx limit)
1544      (%ioblock-force-output ioblock nil)
1545      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
1546    (setf (aref (the (simple-array (unsigned-byte 8) (*)) (io-buffer-buffer buf)) idx) element)
1547    (incf idx)
1548    (setf (io-buffer-idx buf) idx)
1549    (when (> idx count)
1550      (setf (io-buffer-count buf) idx))
1551    (setf (ioblock-dirty ioblock) t)
1552    element))
1553
1554(declaim (inline %ioblock-write-s8-element))
1555(defun %ioblock-write-s8-element (ioblock element)
1556  (declare (optimize (speed 3) (safety 0)))
1557  (let* ((buf (ioblock-outbuf ioblock))
1558         (idx (io-buffer-idx buf))
1559         (count (io-buffer-count buf))
1560         (limit (io-buffer-limit buf)))
1561    (declare (fixnum idx limit count))
1562    (when (= idx limit)
1563      (%ioblock-force-output ioblock nil)
1564      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
1565    (setf (aref (the (simple-array (signed-byte 8) (*)) (io-buffer-buffer buf)) idx) element)
1566    (incf idx)
1567    (setf (io-buffer-idx buf) idx)
1568    (when (> idx count)
1569      (setf (io-buffer-count buf) idx))
1570    (setf (ioblock-dirty ioblock) t)
1571    element))
1572
1573(declaim (inline %ioblock-write-u16-element))
1574(defun %ioblock-write-u16-element (ioblock element)
1575  (declare (optimize (speed 3) (safety 0)))
1576  (let* ((buf (ioblock-outbuf ioblock))
1577         (idx (io-buffer-idx buf))
1578         (count (io-buffer-count buf))
1579         (limit (io-buffer-limit buf)))
1580    (declare (fixnum idx limit count))
1581    (when (= idx limit)
1582      (%ioblock-force-output ioblock nil)
1583      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
1584    (setf (aref (the (simple-array (unsigned-byte 16) (*)) (io-buffer-buffer buf)) idx) element)
1585    (incf idx)
1586    (setf (io-buffer-idx buf) idx)
1587    (when (> idx count)
1588      (setf (io-buffer-count buf) idx))
1589    (setf (ioblock-dirty ioblock) t)
1590    element))
1591
1592(declaim (inline %ioblock-write-u16-code-unit))
1593(defun %ioblock-write-u16-code-unit (ioblock element)
1594  (declare (optimize (speed 3) (safety 0))
1595           (type (unsigned-byte 16) element))
1596  (let* ((buf (ioblock-outbuf ioblock))
1597         (idx (io-buffer-idx buf))
1598         (count (io-buffer-count buf))
1599         (limit (io-buffer-limit buf))
1600         (vector (io-buffer-buffer buf))
1601         (b0 #+big-endian-target (ldb (byte 8 8) element)
1602             #+little-endian-target (ldb (byte 8 0) element))
1603         (b1 #+big-endian-target (ldb (byte 8 0) element)
1604             #+little-endian-target (ldb (byte 8 8) element)))
1605    (declare (fixnum idx limit count)
1606             (type (simple-array (unsigned-byte 8) (*)) vector)
1607             (type (unsigned-byte 8) b0 b1))
1608   
1609    (when (= idx limit)
1610      (%ioblock-force-output ioblock nil)
1611      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
1612    (setf (aref vector idx) b0)
1613    (incf idx)
1614    (when (= idx limit)
1615      (when (> idx count)
1616        (setf (io-buffer-count buf) idx))
1617      (%ioblock-force-output ioblock nil)
1618      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
1619    (setf (aref vector idx) b1)
1620    (incf idx)
1621    (setf (io-buffer-idx buf) idx)
1622    (when (> idx count)
1623      (setf (io-buffer-count buf) idx))
1624    (setf (ioblock-dirty ioblock) t)
1625    element))
1626
1627(declaim (inline %ioblock-write-swapped-u16-code-unit))
1628(defun %ioblock-write-swapped-u16-code-unit (ioblock element)
1629  (declare (optimize (speed 3) (safety 0)))
1630(let* ((buf (ioblock-outbuf ioblock))
1631         (idx (io-buffer-idx buf))
1632         (count (io-buffer-count buf))
1633         (limit (io-buffer-limit buf))
1634         (vector (io-buffer-buffer buf))
1635         (b0 #+big-endian-target (ldb (byte 8 8) element)
1636             #+little-endian-target (ldb (byte 8 0) element))
1637         (b1 #+big-endian-target (ldb (byte 8 0) element)
1638             #+little-endian-target (ldb (byte 8 8) element)))
1639    (declare (fixnum idx limit count)
1640             (type (simple-array (unsigned-byte 8) (*)) vector)
1641             (type (unsigned-byte 8) b0 b1))
1642   
1643    (when (= idx limit)
1644      (%ioblock-force-output ioblock nil)
1645      (setq idx (io-buffer-idx buf)
1646            count (io-buffer-count buf)
1647            vector (io-buffer-buffer buf)
1648            limit (io-buffer-limit buf)))
1649    (setf (aref vector idx) b1)
1650    (incf idx)
1651    (when (= idx limit)
1652      (when (> idx count)
1653        (setf (io-buffer-count buf) idx))
1654      (%ioblock-force-output ioblock nil)
1655      (setq idx (io-buffer-idx buf)
1656            count (io-buffer-count buf)
1657            vector (io-buffer-buffer buf)
1658            limit (io-buffer-limit buf)))
1659    (setf (aref vector idx) b0)
1660    (incf idx)
1661    (setf (io-buffer-idx buf) idx)
1662    (when (> idx count)
1663      (setf (io-buffer-count buf) idx))
1664    (setf (ioblock-dirty ioblock) t)
1665    element))
1666
1667(declaim (inline %ioblock-write-u32-code-unit))
1668(defun %ioblock-write-u32-code-unit (ioblock element)
1669  (declare (optimize (speed 3) (safety 0))
1670           (type (unsigned-byte 16) element))
1671  (let* ((buf (ioblock-outbuf ioblock))
1672         (idx (io-buffer-idx buf))
1673         (count (io-buffer-count buf))
1674         (limit (io-buffer-limit buf))
1675         (vector (io-buffer-buffer buf))
1676         (b0 #+big-endian-target (ldb (byte 8 24) element)
1677             #+little-endian-target (ldb (byte 8 0) element))
1678         (b1 #+big-endian-target (ldb (byte 8 16) element)
1679             #+little-endian-target (ldb (byte 8 8) element))
1680         (b2 #+big-endian-target (ldb (byte 8 8) element)
1681             #+little-endian-target (ldb (byte 8 16) element))
1682         (b3 #+big-endian-target (ldb (byte 8 0) element)
1683             #+little-endian-target (ldb (byte 8 24) element)))
1684    (declare (fixnum idx limit count)
1685             (type (simple-array (unsigned-byte 8) (*)) vector)
1686             (type (unsigned-byte 8) b0 b1 b2 b3))
1687    (when (= idx limit)
1688      (%ioblock-force-output ioblock nil)
1689      (setq idx (io-buffer-idx buf)
1690            count (io-buffer-count buf)
1691            vector (io-buffer-buffer buf)
1692            limit (io-buffer-limit buf)))
1693    (setf (aref vector idx) b0)
1694    (incf idx)
1695    (when (= idx limit)
1696      (when (> idx count)
1697        (setf (io-buffer-count buf) idx))
1698      (%ioblock-force-output ioblock nil)
1699      (setq idx (io-buffer-idx buf)
1700            count (io-buffer-count buf)
1701            vector (io-buffer-buffer buf)
1702            limit (io-buffer-limit buf)))
1703    (setf (aref vector idx) b1)
1704    (incf idx)
1705    (when (= idx limit)
1706      (when (> idx count)
1707        (setf (io-buffer-count buf) idx))
1708      (%ioblock-force-output ioblock nil)
1709      (setq idx (io-buffer-idx buf)
1710            count (io-buffer-count buf)
1711            vector (io-buffer-buffer buf)
1712            limit (io-buffer-limit buf)))
1713    (setf (aref vector idx) b2)
1714    (incf idx)
1715    (when (= idx limit)
1716      (when (> idx count)
1717        (setf (io-buffer-count buf) idx))
1718      (%ioblock-force-output ioblock nil)
1719      (setq idx (io-buffer-idx buf)
1720            count (io-buffer-count buf)
1721            vector (io-buffer-buffer buf)
1722            limit (io-buffer-limit buf)))
1723    (setf (aref vector idx) b3)
1724    (incf idx)
1725    (setf (io-buffer-idx buf) idx)
1726    (when (> idx count)
1727      (setf (io-buffer-count buf) idx))
1728    (setf (ioblock-dirty ioblock) t)
1729    element))
1730
1731(declaim (inline %ioblock-write-swapped-u32-code-unit))
1732(defun %ioblock-write-swapped-u32-code-unit (ioblock element)
1733  (declare (optimize (speed 3) (safety 0))
1734           (type (unsigned-byte 16) element))
1735  (let* ((buf (ioblock-outbuf ioblock))
1736         (idx (io-buffer-idx buf))
1737         (count (io-buffer-count buf))
1738         (limit (io-buffer-limit buf))
1739         (vector (io-buffer-buffer buf))
1740         (b0 #+little-endian-target (ldb (byte 8 24) element)
1741             #+big-endian-target (ldb (byte 8 0) element))
1742         (b1 #+little-endian-target (ldb (byte 8 16) element)
1743             #+big-endian-target (ldb (byte 8 8) element))
1744         (b2 #+little-endian-target (ldb (byte 8 8) element)
1745             #+big-endian-target (ldb (byte 8 16) element))
1746         (b3 #+little-endian-target (ldb (byte 8 0) element)
1747             #+big-endian-target (ldb (byte 8 24) element)))
1748    (declare (fixnum idx limit count)
1749             (type (simple-array (unsigned-byte 8) (*)) vector)
1750             (type (unsigned-byte 8) b0 b1 b2 b3))
1751    (when (= idx limit)
1752      (%ioblock-force-output ioblock nil)
1753      (setq idx (io-buffer-idx buf)
1754            count (io-buffer-count buf)
1755            vector (io-buffer-buffer buf)
1756            limit (io-buffer-limit buf)))
1757    (setf (aref vector idx) b0)
1758    (incf idx)
1759    (when (= idx limit)
1760      (when (> idx count)
1761        (setf (io-buffer-count buf) idx))
1762      (%ioblock-force-output ioblock nil)
1763      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
1764    (setf (aref vector idx) b1)
1765    (incf idx)
1766    (when (= idx limit)
1767      (when (> idx count)
1768        (setf (io-buffer-count buf) idx))
1769      (%ioblock-force-output ioblock nil)
1770      (setq idx (io-buffer-idx buf)
1771            count (io-buffer-count buf)
1772            vector (io-buffer-buffer buf)
1773            limit (io-buffer-limit buf)))
1774    (setf (aref vector idx) b2)
1775    (incf idx)
1776    (when (= idx limit)
1777      (when (> idx count)
1778        (setf (io-buffer-count buf) idx))
1779      (%ioblock-force-output ioblock nil)
1780      (setq idx (io-buffer-idx buf)
1781            count (io-buffer-count buf)
1782            vector (io-buffer-buffer buf)
1783            limit (io-buffer-limit buf)))
1784    (setf (aref vector idx) b3)
1785    (incf idx)
1786    (setf (io-buffer-idx buf) idx)
1787    (when (> idx count)
1788      (setf (io-buffer-count buf) idx))
1789    (setf (ioblock-dirty ioblock) t)
1790    element))
1791
1792(declaim (inline %ioblock-write-s16-element))
1793(defun %ioblock-write-s16-element (ioblock element)
1794  (declare (optimize (speed 3) (safety 0)))
1795  (let* ((buf (ioblock-outbuf ioblock))
1796         (idx (io-buffer-idx buf))
1797         (count (io-buffer-count buf))
1798         (limit (io-buffer-limit buf)))
1799    (declare (fixnum idx limit count))
1800    (when (= idx limit)
1801      (%ioblock-force-output ioblock nil)
1802      (setq idx (io-buffer-idx buf)
1803            count (io-buffer-count buf)))
1804    (setf (aref (the (simple-array (signed-byte 16) (*)) (io-buffer-buffer buf)) idx) element)
1805    (incf idx)
1806    (setf (io-buffer-idx buf) idx)
1807    (when (> idx count)
1808      (setf (io-buffer-count buf) idx))
1809    (setf (ioblock-dirty ioblock) t)
1810    element))
1811
1812(declaim (inline %ioblock-write-u32-element))
1813(defun %ioblock-write-u32-element (ioblock element)
1814  (declare (optimize (speed 3) (safety 0)))
1815  (let* ((buf (ioblock-outbuf ioblock))
1816         (idx (io-buffer-idx buf))
1817         (count (io-buffer-count buf))
1818         (limit (io-buffer-limit buf)))
1819    (declare (fixnum idx limit count))
1820    (when (= idx limit)
1821      (%ioblock-force-output ioblock nil)
1822      (setq idx (io-buffer-idx buf)
1823            count (io-buffer-count buf)))
1824    (setf (aref (the (simple-array (unsigned-byte 32) (*)) (io-buffer-buffer buf)) idx) element)
1825    (incf idx)
1826    (setf (io-buffer-idx buf) idx)
1827    (when (> idx count)
1828      (setf (io-buffer-count buf) idx))
1829    (setf (ioblock-dirty ioblock) t)
1830    element))
1831
1832(declaim (inline %ioblock-write-swapped-u32-element))
1833(defun %ioblock-write-swapped-u32-element (ioblock element)
1834  (declare (optimize (speed 3) (safety 0)))
1835  (let* ((buf (ioblock-outbuf ioblock))
1836         (idx (io-buffer-idx buf))
1837         (count (io-buffer-count buf))
1838         (limit (io-buffer-limit buf)))
1839    (declare (fixnum idx limit count))
1840    (when (= idx limit)
1841      (%ioblock-force-output ioblock nil)
1842      (setq idx (io-buffer-idx buf)
1843            count (io-buffer-count buf)))
1844    (setf (aref (the (simple-array (unsigned-byte 32) (*)) (io-buffer-buffer buf)) idx)
1845          (%swap-u32 element))
1846    (incf idx)
1847    (setf (io-buffer-idx buf) idx)
1848    (when (> idx count)
1849      (setf (io-buffer-count buf) idx))
1850    (setf (ioblock-dirty ioblock) t)
1851    element))
1852
1853(declaim (inline %ioblock-write-s32-element))
1854(defun %ioblock-write-s32-element (ioblock element)
1855  (declare (optimize (speed 3) (safety 0)))
1856  (let* ((buf (ioblock-outbuf ioblock))
1857         (idx (io-buffer-idx buf))
1858         (count (io-buffer-count buf))
1859         (limit (io-buffer-limit buf)))
1860    (declare (fixnum idx limit count))
1861    (when (= idx limit)
1862      (%ioblock-force-output ioblock nil)
1863      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
1864    (setf (aref (the (simple-array (signed-byte 32) (*)) (io-buffer-buffer buf)) idx) element)
1865    (incf idx)
1866    (setf (io-buffer-idx buf) idx)
1867    (when (> idx count)
1868      (setf (io-buffer-count buf) idx))
1869    (setf (ioblock-dirty ioblock) t)
1870    element))
1871
1872#+64-bit-target
1873(progn
1874(declaim (inline %ioblock-write-u64-element))
1875(defun %ioblock-write-u64-element (ioblock element)
1876  (declare (optimize (speed 3) (safety 0)))
1877  (let* ((buf (ioblock-outbuf ioblock))
1878         (idx (io-buffer-idx buf))
1879         (count (io-buffer-count buf))
1880         (limit (io-buffer-limit buf)))
1881    (declare (fixnum idx limit count))
1882    (when (= idx limit)
1883      (%ioblock-force-output ioblock nil)
1884      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
1885    (setf (aref (the (simple-array (unsigned-byte 64) (*)) (io-buffer-buffer buf)) idx) element)
1886    (incf idx)
1887    (setf (io-buffer-idx buf) idx)
1888    (when (> idx count)
1889      (setf (io-buffer-count buf) idx))
1890    (setf (ioblock-dirty ioblock) t)
1891    element))
1892
1893(declaim (inline %ioblock-write-s64-element))
1894(defun %ioblock-write-s64-element (ioblock element)
1895  (declare (optimize (speed 3) (safety 0)))
1896  (let* ((buf (ioblock-outbuf ioblock))
1897         (idx (io-buffer-idx buf))
1898         (count (io-buffer-count buf))
1899         (limit (io-buffer-limit buf)))
1900    (declare (fixnum idx limit count))
1901    (when (= idx limit)
1902      (%ioblock-force-output ioblock nil)
1903      (setq idx (io-buffer-idx buf) count (io-buffer-count buf)))
1904    (setf (aref (the (simple-array (signed-byte 64) (*)) (io-buffer-buffer buf)) idx) element)
1905    (incf idx)
1906    (setf (io-buffer-idx buf) idx)
1907    (when (> idx count)
1908      (setf (io-buffer-count buf) idx))
1909    (setf (ioblock-dirty ioblock) t)
1910    element))
1911)
1912
1913(declaim (inline %ioblock-write-char))
1914(defun %ioblock-write-char (ioblock char)
1915  (declare (optimize (speed 3) (safety 0)))
1916  (if (eq char #\linefeed)
1917    (setf (ioblock-charpos ioblock) 0)
1918    (incf (ioblock-charpos ioblock)))
1919  (let* ((code (char-code char)))
1920    (declare (type (mod #x110000) code))
1921    (if (< code 256)
1922      (%ioblock-write-u8-element ioblock code)
1923      (%ioblock-write-u8-element ioblock (char-code #\Sub)))))
1924
1925(defun %private-ioblock-write-char (ioblock char)
1926  (declare (optimize (speed 3) (safety 0)))
1927  (check-ioblock-owner ioblock)
1928  (%ioblock-write-char ioblock char))
1929
1930(defun %locked-ioblock-write-char (ioblock char)
1931  (declare (optimize (speed 3) (safety 0)))
1932  (with-ioblock-output-lock-grabbed (ioblock)
1933    (%ioblock-write-char ioblock char)))
1934
1935(declaim (inline %ioblock-write-u8-encoded-char))
1936(defun %ioblock-write-u8-encoded-char (ioblock char)
1937  (declare (optimize (speed 3) (safety 0)))
1938  (if (eq char #\linefeed)
1939    (setf (ioblock-charpos ioblock) 0)
1940    (incf (ioblock-charpos ioblock)))
1941  (let* ((code (char-code char)))
1942    (declare (type (mod #x110000) code))
1943    (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock)))
1944      (%ioblock-write-u8-element ioblock code)
1945      (funcall (ioblock-encode-output-function ioblock)
1946               char
1947               #'%ioblock-write-u8-element
1948               ioblock))))
1949
1950(defun %private-ioblock-write-u8-encoded-char (ioblock char)
1951  (declare (optimize (speed 3) (safety 0)))
1952  (check-ioblock-owner ioblock)
1953  (%ioblock-write-u8-encoded-char ioblock char))
1954
1955(defun %locked-ioblock-write-u8-encoded-char (ioblock char)
1956  (declare (optimize (speed 3) (safety 0)))
1957  (with-ioblock-output-lock-grabbed (ioblock) 
1958    (%ioblock-write-u8-encoded-char ioblock char)))
1959
1960
1961(defun %ioblock-write-u8-encoded-simple-string (ioblock string start-char num-chars)
1962  (declare (fixnum start-char num-chars)
1963           (simple-base-string string)
1964           (optimize (speed 3) (safety 0)))
1965  (do* ((i 0 (1+ i))
1966        (col (ioblock-charpos ioblock))
1967        (limit (ioblock-encode-literal-char-code-limit ioblock))
1968        (encode-function (ioblock-encode-output-function ioblock))
1969        (start-char start-char (1+ start-char)))
1970       ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
1971    (declare (fixnum i start-char limit))
1972    (let* ((char (schar string start-char))
1973           (code (char-code char)))
1974      (declare (type (mod #x110000) code))
1975      (if (eq char #\newline)
1976        (setq col 0)
1977        (incf col))
1978      (if (< code limit)
1979        (%ioblock-write-u8-element ioblock code)
1980        (funcall encode-function char #'%ioblock-write-u8-element ioblock)))))
1981
1982
1983(declaim (inline %ioblock-write-u16-encoded-char))
1984(defun %ioblock-write-u16-encoded-char (ioblock char)
1985  (declare (optimize (speed 3) (safety 0)))
1986  (when (ioblock-pending-byte-order-mark ioblock)
1987    (setf (ioblock-pending-byte-order-mark ioblock) nil)
1988    (%ioblock-write-u16-code-unit ioblock byte-order-mark-char-code))
1989  (if (eq char #\linefeed)
1990    (setf (ioblock-charpos ioblock) 0)
1991    (incf (ioblock-charpos ioblock)))
1992  (let* ((code (char-code char)))
1993    (declare (type (mod #x110000) code))
1994    (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock)))
1995      (%ioblock-write-u16-code-unit ioblock code)
1996      (funcall (ioblock-encode-output-function ioblock)
1997               char
1998               #'%ioblock-write-u16-code-unit
1999               ioblock))))
2000
2001(defun %private-ioblock-write-u16-encoded-char (ioblock char)
2002  (declare (optimize (speed 3) (safety 0)))
2003  (check-ioblock-owner ioblock)
2004  (%ioblock-write-u16-encoded-char ioblock char))
2005
2006(defun %locked-ioblock-write-u16-encoded-char (ioblock char)
2007  (declare (optimize (speed 3) (safety 0)))
2008  (with-ioblock-output-lock-grabbed (ioblock)
2009    (%ioblock-write-u16-encoded-char ioblock char)))
2010
2011
2012(defun %ioblock-write-u16-encoded-simple-string (ioblock string start-char num-chars)
2013  (declare (fixnum start-char num-chars)
2014           (simple-base-string string)
2015           (optimize (speed 3) (safety 0)))
2016  (when (ioblock-pending-byte-order-mark ioblock)
2017    (setf (ioblock-pending-byte-order-mark ioblock) nil)
2018    (%ioblock-write-u16-code-unit ioblock byte-order-mark-char-code))
2019  (do* ((i 0 (1+ i))
2020        (col (ioblock-charpos ioblock))
2021        (limit (ioblock-encode-literal-char-code-limit ioblock))
2022        (encode-function (ioblock-encode-output-function ioblock))
2023        (start-char start-char (1+ start-char)))
2024       ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
2025    (declare (fixnum i start-char limit))
2026    (let* ((char (schar string start-char))
2027           (code (char-code char)))
2028      (declare (type (mod #x110000) code))
2029      (if (eq char #\newline)
2030        (setq col 0)
2031        (incf col))
2032      (if (< code limit)
2033        (%ioblock-write-u16-code-unit ioblock code)
2034        (funcall encode-function char #'%ioblock-write-u16-code-unit ioblock)))))
2035
2036(declaim (inline %ioblock-write-swapped-u16-encoded-char))
2037(defun %ioblock-write-swapped-u16-encoded-char (ioblock char)
2038  (declare (optimize (speed 3) (safety 0)))
2039  (if (eq char #\linefeed)
2040    (setf (ioblock-charpos ioblock) 0)
2041    (incf (ioblock-charpos ioblock)))
2042  (let* ((code (char-code char)))
2043    (declare (type (mod #x110000) code))
2044    (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock)))
2045      (%ioblock-write-swapped-u16-code-unit ioblock code)
2046      (funcall (ioblock-encode-output-function ioblock)
2047               char
2048               #'%ioblock-write-swapped-u16-code-unit
2049               ioblock))))
2050
2051(defun %private-ioblock-write-swapped-u16-encoded-char (ioblock char)
2052  (declare (optimize (speed 3) (safety 0)))
2053  (check-ioblock-owner ioblock)
2054  (%ioblock-write-swapped-u16-encoded-char ioblock char))
2055
2056(defun %locked-ioblock-write-swapped-u16-encoded-char (ioblock char)
2057  (declare (optimize (speed 3) (safety 0)))
2058  (with-ioblock-output-lock-grabbed (ioblock)
2059    (%ioblock-write-swapped-u16-encoded-char ioblock char)))
2060
2061(defun %ioblock-write-swapped-u16-encoded-simple-string (ioblock string start-char num-chars)
2062  (declare (fixnum start-char num-chars)
2063           (simple-base-string string)
2064           (optimize (speed 3) (safety 0)))
2065  (do* ((i 0 (1+ i))
2066        (col (ioblock-charpos ioblock))
2067        (limit (ioblock-encode-literal-char-code-limit ioblock))
2068        (encode-function (ioblock-encode-output-function ioblock))
2069        (wcf (ioblock-write-char-when-locked-function ioblock))
2070        (start-char start-char (1+ start-char)))
2071       ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
2072    (declare (fixnum i start-char limit))
2073    (let* ((char (schar string start-char))
2074           (code (char-code char)))
2075      (declare (type (mod #x110000) code))
2076      (cond ((eq char #\newline)
2077             (setq col 0)
2078             (funcall wcf ioblock char))
2079            (t
2080             (incf col)
2081             (if (< code limit)
2082               (%ioblock-write-swapped-u16-code-unit ioblock code)
2083               (funcall encode-function char #'%ioblock-write-swapped-u16-code-unit ioblock)))))))
2084
2085
2086(declaim (inline %ioblock-write-u32-encoded-char))
2087(defun %ioblock-write-u32-encoded-char (ioblock char)
2088  (declare (optimize (speed 3) (safety 0)))
2089  (when (ioblock-pending-byte-order-mark ioblock)
2090    (setf (ioblock-pending-byte-order-mark ioblock) nil)
2091    (%ioblock-write-u32-code-unit ioblock byte-order-mark))
2092  (if (eq char #\linefeed)
2093    (setf (ioblock-charpos ioblock) 0)
2094    (incf (ioblock-charpos ioblock)))
2095  (let* ((code (char-code char)))
2096    (declare (type (mod #x110000) code))
2097    (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock)))
2098      (%ioblock-write-u32-code-unit ioblock code)
2099      (funcall (ioblock-encode-output-function ioblock)
2100               code
2101               #'%ioblock-write-u32-code-unit
2102               ioblock))))
2103
2104(defun %private-ioblock-write-u32-encoded-char (ioblock char)
2105  (declare (optimize (speed 3) (safety 0)))
2106  (check-ioblock-owner ioblock)
2107  (%ioblock-write-u32-encoded-char ioblock char))
2108
2109(defun %locked-ioblock-write-u32-encoded-char (ioblock char)
2110  (declare (optimize (speed 3) (safety 0))) 
2111  (with-ioblock-output-lock-grabbed (ioblock)
2112    (%ioblock-write-u32-encoded-char ioblock char)))
2113
2114(defun %ioblock-write-u32-encoded-simple-string (ioblock string start-char num-chars)
2115  (declare (fixnum start-char num-chars)
2116           (simple-base-string string)
2117           (optimize (speed 3) (safety 0)))
2118  (when (ioblock-pending-byte-order-mark ioblock)
2119    (setf (ioblock-pending-byte-order-mark ioblock) nil)
2120    (%ioblock-write-u32-code-unit ioblock byte-order-mark-char-code))
2121  (do* ((i 0 (1+ i))
2122        (col (ioblock-charpos ioblock))
2123        (limit (ioblock-encode-literal-char-code-limit ioblock))
2124        (encode-function (ioblock-encode-output-function ioblock))
2125        (start-char start-char (1+ start-char)))
2126       ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
2127    (declare (fixnum i start-char limit))
2128    (let* ((char (schar string start-char))
2129           (code (char-code char)))
2130      (declare (type (mod #x110000) code))
2131      (if (eq char #\newline)
2132        (setq col 0)
2133        (incf col))
2134      (if (< code limit)
2135        (%ioblock-write-u32-code-unit ioblock code)
2136        (funcall encode-function char #'%ioblock-write-u32-code-unit ioblock)))))
2137
2138
2139(declaim (inline %ioblock-write-swapped-u32-encoded-char))
2140(defun %ioblock-write-swapped-u32-encoded-char (ioblock char)
2141  (declare (optimize (speed 3) (safety 0)))
2142  (if (eq char #\linefeed)
2143    (setf (ioblock-charpos ioblock) 0)
2144    (incf (ioblock-charpos ioblock)))
2145  (let* ((code (char-code char)))
2146    (declare (type (mod #x110000) code))
2147    (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock)))
2148      (%ioblock-write-swapped-u32-code-unit ioblock code)
2149      (funcall (ioblock-encode-output-function ioblock)
2150               code
2151               #'%ioblock-write-swapped-u32-code-unit
2152               ioblock))))
2153
2154(defun %private-ioblock-write-swapped-u32-encoded-char (ioblock char)
2155  (declare (optimize (speed 3) (safety 0)))
2156  (check-ioblock-owner ioblock)
2157  (%ioblock-write-swapped-u32-encoded-char ioblock char))
2158
2159(defun %locked-ioblock-write-swapped-u32-encoded-char (ioblock char)
2160  (declare (optimize (speed 3) (safety 0))) 
2161  (with-ioblock-output-lock-grabbed (ioblock)
2162    (%ioblock-write-swapped-u32-encoded-char ioblock char)))
2163
2164(defun %ioblock-write-swapped-u32-encoded-simple-string (ioblock string start-char num-chars)
2165  (declare (fixnum start-char num-chars)
2166           (simple-base-string string)
2167           (optimize (speed 3) (safety 0)))
2168  (do* ((i 0 (1+ i))
2169        (col (ioblock-charpos ioblock))
2170        (limit (ioblock-encode-literal-char-code-limit ioblock))
2171        (encode-function (ioblock-encode-output-function ioblock))
2172        (start-char start-char (1+ start-char)))
2173       ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
2174    (declare (fixnum i start-char limit))
2175    (let* ((char (schar string start-char))
2176           (code (char-code char)))
2177      (declare (type (mod #x110000) code))
2178      (if (eq char #\newline)
2179        (setq col 0)
2180        (incf col))
2181      (if (< code limit)
2182        (%ioblock-write-swapped-u32-code-unit ioblock code)
2183        (funcall encode-function char #'%ioblock-write-swapped-u32-code-unit ioblock)))))
2184
2185(declaim (inline %ioblock-write-u8-byte))
2186(defun %ioblock-write-u8-byte (ioblock byte)
2187  (declare (optimize (speed 3) (safety 0)))
2188  (%ioblock-write-u8-element ioblock (require-type byte '(unsigned-byte 8))))
2189
2190(defun %private-ioblock-write-u8-byte (ioblock byte)
2191  (declare (optimize (speed 3) (safety 0)))
2192  (check-ioblock-owner ioblock)
2193  (%ioblock-write-u8-byte ioblock byte))
2194
2195(defun %locked-ioblock-write-u8-byte (ioblock byte)
2196  (declare (optimize (speed 3) (safety 0)))
2197  (with-ioblock-output-lock-grabbed (ioblock)
2198    (%ioblock-write-u8-byte ioblock byte)))
2199
2200(declaim (inline %ioblock-write-s8-byte))
2201(defun %ioblock-write-s8-byte (ioblock byte)
2202  (declare (optimize (speed 3) (safety 0)))
2203  (%ioblock-write-s8-element ioblock (require-type byte '(signed-byte 8))))
2204
2205(defun %private-ioblock-write-s8-byte (ioblock byte)
2206  (declare (optimize (speed 3) (safety 0)))
2207  (check-ioblock-owner ioblock)
2208  (%ioblock-write-s8-byte ioblock byte))
2209
2210(defun %locked-ioblock-write-s8-byte (ioblock byte)
2211  (declare (optimize (speed 3) (safety 0)))
2212  (with-ioblock-output-lock-grabbed (ioblock)
2213    (%ioblock-write-s8-byte ioblock byte)))
2214
2215(declaim (inline %ioblock-write-u16-byte))
2216(defun %ioblock-write-u16-byte (ioblock byte)
2217  (declare (optimize (speed 3) (safety 0)))
2218  (%ioblock-write-u16-element ioblock (require-type byte '(unsigned-byte 16))))
2219
2220(defun %private-ioblock-write-u16-byte (ioblock byte)
2221  (declare (optimize (speed 3) (safety 0)))
2222  (check-ioblock-owner ioblock)
2223  (%ioblock-write-u16-byte ioblock byte))
2224
2225(defun %locked-ioblock-write-u16-byte (ioblock byte)
2226  (declare (optimize (speed 3) (safety 0)))
2227  (with-ioblock-output-lock-grabbed (ioblock)
2228    (%ioblock-write-u16-byte ioblock byte)))
2229
2230(declaim (inline %ioblock-write-s16-byte))
2231(defun %ioblock-write-s16-byte (ioblock byte)
2232  (declare (optimize (speed 3) (safety 0)))
2233  (%ioblock-write-s16-element ioblock (require-type byte '(signed-byte 16))))
2234
2235(defun %private-ioblock-write-s16-byte (ioblock byte)
2236  (declare (optimize (speed 3) (safety 0)))
2237  (check-ioblock-owner ioblock)
2238  (%ioblock-write-s16-byte ioblock byte))
2239
2240(defun %locked-ioblock-write-s16-byte (ioblock byte)
2241  (declare (optimize (speed 3) (safety 0)))
2242  (with-ioblock-output-lock-grabbed (ioblock)
2243    (%ioblock-write-s16-byte ioblock byte)))
2244
2245(declaim (inline %ioblock-write-u32-byte))
2246(defun %ioblock-write-u32-byte (ioblock byte)
2247  (declare (optimize (speed 3) (safety 0)))
2248  (%ioblock-write-u32-element ioblock (require-type byte '(unsigned-byte 32))))
2249
2250(defun %private-ioblock-write-u32-byte (ioblock byte)
2251  (declare (optimize (speed 3) (safety 0)))
2252  (check-ioblock-owner ioblock)
2253  (%ioblock-write-u32-byte ioblock byte))
2254
2255(defun %locked-ioblock-write-u32-byte (ioblock byte)
2256  (declare (optimize (speed 3) (safety 0)))
2257  (with-ioblock-output-lock-grabbed (ioblock)
2258    (%ioblock-write-u32-byte ioblock byte)))
2259
2260(declaim (inline %ioblock-write-s32-byte))
2261(defun %ioblock-write-s32-byte (ioblock byte)
2262  (declare (optimize (speed 3) (safety 0)))
2263  (%ioblock-write-s32-element ioblock (require-type byte '(signed-byte 32))))
2264
2265(defun %private-ioblock-write-s32-byte (ioblock byte)
2266  (declare (optimize (speed 3) (safety 0)))
2267  (check-ioblock-owner ioblock)
2268  (%ioblock-write-s32-byte ioblock byte))
2269
2270(defun %locked-ioblock-write-s32-byte (ioblock byte)
2271  (declare (optimize (speed 3) (safety 0)))
2272  (with-ioblock-output-lock-grabbed (ioblock)
2273    (%ioblock-write-s32-byte ioblock byte)))
2274
2275#+64-bit-target
2276(progn
2277(declaim (inline %ioblock-write-u64-byte))
2278(defun %ioblock-write-u64-byte (ioblock byte)
2279  (declare (optimize (speed 3) (safety 0)))
2280  (%ioblock-write-u64-element ioblock (require-type byte '(unsigned-byte 64))))
2281
2282(defun %private-ioblock-write-u64-byte (ioblock byte)
2283  (declare (optimize (speed 3) (safety 0)))
2284  (check-ioblock-owner ioblock)
2285  (%ioblock-write-u64-byte ioblock byte))
2286
2287(defun %locked-ioblock-write-u64-byte (ioblock byte)
2288  (declare (optimize (speed 3) (safety 0)))
2289  (with-ioblock-output-lock-grabbed (ioblock)
2290    (%ioblock-write-u64-byte ioblock byte)))
2291
2292(declaim (inline %ioblock-write-s64-byte))
2293(defun %ioblock-write-s64-byte (ioblock byte)
2294  (declare (optimize (speed 3) (safety 0)))
2295  (%ioblock-write-s64-element ioblock (require-type byte '(signed-byte 64))))
2296
2297(defun %private-ioblock-write-s64-byte (ioblock byte)
2298  (declare (optimize (speed 3) (safety 0)))
2299  (check-ioblock-owner ioblock)
2300  (%ioblock-write-s64-byte ioblock byte))
2301
2302(defun %locked-ioblock-write-s64-byte (ioblock byte)
2303  (declare (optimize (speed 3) (safety 0)))
2304  (with-ioblock-output-lock-grabbed (ioblock)
2305    (%ioblock-write-s64-byte ioblock byte)))
2306)                                       ;#+64-bit-target
2307
2308(defun %ioblock-clear-output (ioblock)
2309  (let* ((buf (ioblock-outbuf ioblock)))                     
2310    (setf (io-buffer-count buf) 0
2311            (io-buffer-idx buf) 0)))
2312
2313
2314(defun %ioblock-unencoded-read-line (ioblock)
2315  (declare (optimize (speed 3) (safety 0)))
2316  (collect ((octet-vectors))
2317    (let* ((inbuf (ioblock-inbuf ioblock))
2318           (len 0)
2319           (buf (io-buffer-buffer inbuf)))
2320      (declare (fixnum len) (type (simple-array (unsigned-byte 8)(*)) buf))
2321      (let* ((ch (ioblock-untyi-char ioblock)))
2322        (when ch
2323          (setf (ioblock-untyi-char ioblock) nil)
2324          (if (eql ch #\newline)
2325            (return-from %ioblock-unencoded-read-line 
2326              (values "" nil))
2327            (progn
2328              (octet-vectors (make-array 1 :element-type '(unsigned-byte 8)
2329                                         :initial-element (char-code ch)))
2330              (setq len 1)))))
2331      (do* ((done nil)
2332            (idx (io-buffer-idx inbuf))
2333            (count (io-buffer-count inbuf)))
2334           (done (let* ((string (make-string len))
2335                        (outpos 0))
2336                   (declare (simple-string string) (fixnum outpos))
2337                   (dolist (v (octet-vectors) (values string (eq done :eof)))
2338                     (let* ((vlen (length v)))
2339                       (declare (fixnum vlen))
2340                       (%copy-u8-to-string v 0 string outpos vlen)
2341                       (incf outpos vlen)))))
2342        (declare (fixnum idx count))
2343        (when (= idx count)
2344          (%ioblock-advance ioblock t)
2345          (setq idx (io-buffer-idx inbuf)
2346                count (io-buffer-count inbuf)
2347                done (if (= idx count) :eof)))
2348        (unless done
2349          (let* ((p (do* ((i idx (1+ i)))
2350                         ((= i count)
2351                          (setf (io-buffer-idx inbuf) count)
2352                          nil)
2353                      (declare (fixnum i))
2354                      (when (eql (aref buf i) (char-code #\newline))
2355                        (setf (io-buffer-idx inbuf) (the fixnum (1+ i)))
2356                        (setq done t)
2357                        (return i))))
2358                 (end (or p count))
2359                 (n (- end idx)))
2360            (declare (fixnum p end n))
2361            (if (and p (eql len 0))
2362              ;; Likely a fairly common case
2363              (let* ((string (make-string n)))
2364                (%copy-u8-to-string buf idx string 0 n)
2365                (return-from %ioblock-unencoded-read-line
2366                  (values string nil)))
2367              (let* ((v (make-array n :element-type '(unsigned-byte 8))))
2368                (%copy-ivector-to-ivector buf idx v 0 n)
2369                (incf len n)
2370                (octet-vectors v)
2371                (setq idx count)))))))))
2372
2373
2374;;; There are lots of ways of doing better here, but in the most general
2375;;; case we can't tell (a) what a newline looks like in the buffer or (b)
2376;;; whether there's a 1:1 mapping between code units and characters.
2377(defun %ioblock-encoded-read-line (ioblock)
2378  (declare (optimize (speed 3) (safety 0)))
2379  (collect ((chunks))
2380    (let* ((pos 0)
2381           (len 0)
2382           (chunksize 8192)
2383           (str (make-string chunksize))
2384           (rcf (ioblock-read-char-when-locked-function ioblock))
2385           (eof nil))
2386      (declare (fixnum pos len chunksize)
2387               (simple-string str)
2388               (dynamic-extent str))
2389      (do* ((ch (funcall rcf ioblock) (funcall rcf ioblock)))
2390           ((or (eq ch #\newline) (setq eof (eq ch :eof)))
2391            (if (zerop len)
2392              (values (subseq str 0 pos) eof)
2393              (let* ((outpos 0))
2394                (declare (fixnum outpos))
2395                (setq len (+ len pos))
2396                (let* ((out (make-string len)))
2397                  (dolist (s (chunks))
2398                    (%copy-ivector-to-ivector s 0 out outpos (the fixnum (ash chunksize 2)))
2399                    (incf outpos (ash chunksize 2)))
2400                  (%copy-ivector-to-ivector str 0 out outpos (the fixnum (ash pos 2)))
2401                  (values out eof)))))
2402        (when (= pos chunksize)
2403          (chunks str)
2404          (setq str (make-string chunksize)
2405                len (+ len pos)
2406                pos 0))
2407        (setf (schar str pos) ch
2408              pos (1+ pos))))))
2409         
2410(defun %ioblock-unencoded-character-read-vector (ioblock vector start end)
2411  (do* ((i start)
2412        (in (ioblock-inbuf ioblock))
2413        (inbuf (io-buffer-buffer in))
2414        (need (- end start)))
2415       ((= i end) end)
2416    (declare (fixnum i need))
2417    (let* ((ch (%ioblock-tyi ioblock)))
2418      (if (eq ch :eof)
2419        (return i))
2420      (setf (schar vector i) ch)
2421      (incf i)
2422      (decf need)
2423      (let* ((idx (io-buffer-idx in))
2424             (count (io-buffer-count in))
2425             (avail (- count idx)))
2426        (declare (fixnum idx count avail))
2427        (unless (zerop avail)
2428          (if (> avail need)
2429            (setq avail need))
2430          (%copy-u8-to-string inbuf idx vector i avail)
2431          (setf (io-buffer-idx in) (+ idx avail))
2432          (incf i avail)
2433          (decf need avail))))))
2434
2435;;; Also used when newline translation complicates things.
2436(defun %ioblock-encoded-character-read-vector (ioblock vector start end)
2437  (declare (fixnum start end))
2438  (do* ((i start (1+ i))
2439        (rcf (ioblock-read-char-when-locked-function ioblock)))
2440       ((= i end) end)
2441    (declare (fixnum i))
2442    (let* ((ch (funcall rcf ioblock)))
2443      (if (eq ch :eof)
2444        (return i))
2445      (setf (schar vector i) ch))))
2446
2447
2448(defun %ioblock-binary-read-vector (ioblock vector start end)
2449  (declare (fixnum start end))
2450  (let* ((in (ioblock-inbuf ioblock))
2451         (inbuf (io-buffer-buffer in))
2452         (rbf (ioblock-read-byte-when-locked-function ioblock)))
2453    (setf (ioblock-untyi-char ioblock) nil)
2454    (if (not (= (the fixnum (typecode inbuf))
2455                (the fixnum (typecode vector))))
2456      (do* ((i start (1+ i)))
2457           ((= i end) i)
2458        (declare (fixnum i))
2459        (let* ((b (funcall rbf ioblock)))
2460          (if (eq b :eof)
2461            (return i)
2462            (setf (uvref vector i) b))))
2463      (do* ((i start)
2464            (need (- end start)))
2465           ((= i end) end)
2466        (declare (fixnum i need))
2467        (let* ((b (funcall rbf ioblock)))
2468          (if (eq b :eof)
2469            (return i))
2470          (setf (uvref vector i) b)
2471          (incf i)
2472          (decf need)
2473          (let* ((idx (io-buffer-idx in))
2474                 (count (io-buffer-count in))
2475                 (avail (- count idx)))
2476            (declare (fixnum idx count avail))
2477            (unless (zerop avail)
2478              (if (> avail need)
2479                (setq avail need))
2480              (%copy-ivector-to-ivector
2481               inbuf
2482               (ioblock-elements-to-octets ioblock idx)
2483               vector
2484               (ioblock-elements-to-octets ioblock i)
2485               (ioblock-elements-to-octets ioblock avail))
2486              (setf (io-buffer-idx in) (+ idx avail))
2487              (incf i avail)
2488              (decf need avail))))))))
2489
2490;;; About the same, only less fussy about ivector's element-type.
2491;;; (All fussiness is about the stream's element-type ...).
2492;;; Whatever the element-type is, elements must be 1 octet in size.
2493(defun %ioblock-character-in-ivect (ioblock vector start nb)
2494  (declare (type (simple-array (unsigned-byte 8) (*)) vector)
2495           (fixnum start nb)
2496           (optimize (speed 3) (safety 0)))
2497  (unless (= 0 (the fixnum (ioblock-element-shift ioblock)))
2498    (error "Can't read vector from stream ~s" (ioblock-stream ioblock)))
2499  (do* ((i start)
2500        (in (ioblock-inbuf ioblock))
2501        (inbuf (io-buffer-buffer in))
2502        (need nb)
2503        (end (+ start nb)))
2504       ((= i end) end)
2505    (declare (fixnum i end need))
2506    (let* ((ch (%ioblock-tyi ioblock)))
2507      (if (eq ch :eof)
2508        (return (- i start)))
2509      (setf (aref vector i) (char-code ch))
2510      (incf i)
2511      (decf need)
2512      (let* ((idx (io-buffer-idx in))
2513             (count (io-buffer-count in))
2514             (avail (- count idx)))
2515        (declare (fixnum idx count avail))
2516        (unless (zerop avail)
2517          (if (> avail need)
2518            (setq avail need))
2519          (%copy-u8-to-string inbuf idx vector i avail)
2520          (setf (io-buffer-idx in) (+ idx avail))
2521          (incf i avail)
2522          (decf need avail))))))
2523
2524(defun %ioblock-binary-in-ivect (ioblock vector start nb)
2525  (declare (type (simple-array (unsigned-byte 8) (*)) vector)
2526           (fixnum start nb)
2527           (optimize (speed 3) (safety 0)))
2528  (unless (= 0 (the fixnum (ioblock-element-shift ioblock)))
2529    (error "Can't read vector from stream ~s" (ioblock-stream ioblock)))
2530  (setf (ioblock-untyi-char ioblock) nil)
2531  (do* ((i start)
2532        (rbf (ioblock-read-byte-when-locked-function ioblock))
2533        (in (ioblock-inbuf ioblock))
2534        (inbuf (io-buffer-buffer in))
2535        (need nb)
2536        (end (+ start nb)))
2537       ((= i end) nb)
2538    (declare (fixnum i end need))
2539    (let* ((b (funcall rbf ioblock)))
2540      (if (eq b :eof)
2541        (return (- i start)))
2542      (setf (aref vector i) b)
2543      (incf i)
2544      (decf need)
2545      (let* ((idx (io-buffer-idx in))
2546             (count (io-buffer-count in))
2547             (avail (- count idx)))
2548        (declare (fixnum idx count avail))
2549        (unless (zerop avail)
2550          (if (> avail need)
2551            (setq avail need))
2552          (%copy-ivector-to-ivector inbuf idx vector i avail)
2553          (setf (io-buffer-idx in) (+ idx avail))
2554          (incf i avail)
2555          (decf need avail))))))
2556
2557;;; Thread must own ioblock lock(s).
2558(defun %%ioblock-close (ioblock)
2559  (when (ioblock-device ioblock)
2560    (let* ((stream (ioblock-stream ioblock)))
2561      (funcall (ioblock-close-function ioblock) stream ioblock)
2562      (setf (ioblock-device ioblock) nil)
2563      (setf (stream-ioblock stream) nil)
2564      (let* ((in-iobuf (ioblock-inbuf ioblock))
2565             (out-iobuf (ioblock-outbuf ioblock))
2566             (in-buffer (if in-iobuf (io-buffer-buffer in-iobuf)))
2567             (in-bufptr (if in-iobuf (io-buffer-bufptr in-iobuf)))
2568             (out-buffer (if out-iobuf (io-buffer-buffer out-iobuf)))
2569             (out-bufptr (if out-iobuf (io-buffer-bufptr out-iobuf))))
2570        (if (and in-buffer in-bufptr)
2571          (%dispose-heap-ivector in-buffer))
2572        (unless (eq in-buffer out-buffer)
2573          (if (and out-buffer out-bufptr)
2574            (%dispose-heap-ivector out-buffer)))
2575        (when in-iobuf
2576          (setf (io-buffer-buffer in-iobuf) nil
2577                (io-buffer-bufptr in-iobuf) nil
2578                (ioblock-inbuf ioblock) nil))
2579        (when out-iobuf
2580          (setf (io-buffer-buffer out-iobuf) nil
2581                (io-buffer-bufptr out-iobuf) nil
2582                (ioblock-outbuf ioblock) nil))
2583        t))))
2584
2585(defun %ioblock-close (ioblock)
2586  (let* ((in-lock (ioblock-inbuf-lock ioblock))
2587         (out-lock (ioblock-outbuf-lock ioblock)))
2588    (if in-lock
2589      (with-lock-grabbed (in-lock)
2590        (if (and out-lock (not (eq out-lock in-lock)))
2591          (with-lock-grabbed (out-lock)
2592            (%%ioblock-close ioblock))
2593          (%%ioblock-close ioblock)))
2594      (if out-lock
2595        (with-lock-grabbed (out-lock)
2596          (%%ioblock-close ioblock))
2597        (progn
2598          (check-ioblock-owner ioblock)
2599          (%%ioblock-close ioblock))))))
2600
2601
2602;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2603
2604;;; Character-at-a-time line-termination-translation functions.
2605;;; It's not always possible to just blast through the buffer, blindly
2606;;; replacing #xd with #xa (for example), and it's not always desirable
2607;;; to do that (if we support changing encoding on open streams.)
2608;;; This is done at a fairly high level; some cases could be done at
2609;;; a lower level, and some cases are hard even at that lower level.
2610;;; This approach doesn't slow down the simple case (when no line-termination
2611;;; translation is used), and hopefully isn't -that- bad.
2612
2613(declaim (inline %ioblock-read-char-translating-cr-to-newline))
2614(defun %ioblock-read-char-translating-cr-to-newline (ioblock)
2615  (let* ((ch (funcall
2616              (ioblock-read-char-without-translation-when-locked-function
2617               ioblock)
2618              ioblock)))
2619    (if (eql ch #\Return)
2620      #\Newline
2621      ch)))
2622
2623(defun %private-ioblock-read-char-translating-cr-to-newline (ioblock)
2624  (check-ioblock-owner ioblock)
2625  (%ioblock-read-char-translating-cr-to-newline ioblock))
2626
2627(defun %locked-ioblock-read-char-translating-cr-to-newline (ioblock)
2628  (with-ioblock-input-lock-grabbed (ioblock)
2629    (%ioblock-read-char-translating-cr-to-newline ioblock)))
2630
2631(declaim (inline %ioblock-read-char-translating-crlf-to-newline))
2632(defun %ioblock-read-char-translating-crlf-to-newline (ioblock)
2633  (let* ((ch (funcall
2634              (ioblock-read-char-without-translation-when-locked-function
2635               ioblock)
2636              ioblock)))
2637    (if (eql ch #\Return)
2638      (let* ((next (funcall
2639                    (ioblock-read-char-without-translation-when-locked-function
2640                     ioblock)
2641                    ioblock)))
2642        (if (eql next #\Linefeed)
2643          next
2644          (progn
2645            (unless (eq next :eof)
2646              (setf (ioblock-untyi-char ioblock) next))
2647            ch)))
2648      ch)))
2649   
2650(defun %private-ioblock-read-char-translating-crlf-to-newline (ioblock)
2651  (check-ioblock-owner ioblock)
2652  (%ioblock-read-char-translating-crlf-to-newline ioblock))
2653
2654(defun %locked-ioblock-read-char-translating-crlf-to-newline (ioblock)
2655  (with-ioblock-input-lock-grabbed (ioblock)
2656    (%ioblock-read-char-translating-crlf-to-newline ioblock)))
2657
2658(declaim (inline %ioblock-read-char-translating-line-separator-to-newline))
2659(defun %ioblock-read-char-translating-line-separator-to-newline (ioblock)
2660  (let* ((ch (funcall
2661              (ioblock-read-char-without-translation-when-locked-function
2662               ioblock)
2663              ioblock)))
2664    (if (eql ch #\Line_Separator)
2665      #\Newline
2666      ch)))
2667
2668(defun %private-ioblock-read-char-translating-line-separator-to-newline (ioblock)
2669  (check-ioblock-owner ioblock)
2670  (%ioblock-read-char-translating-line-separator-to-newline ioblock))
2671
2672(defun %locked-ioblock-read-char-translating-line-separator-to-newline (ioblock)
2673  (with-ioblock-input-lock-grabbed (ioblock)
2674    (%ioblock-read-char-translating-line-separator-to-newline ioblock)))
2675
2676(declaim (inline %ioblock-write-char-translating-newline-to-cr))
2677(defun %ioblock-write-char-translating-newline-to-cr (ioblock char)
2678  (funcall (ioblock-write-char-without-translation-when-locked-function
2679            ioblock)
2680           ioblock
2681           (if (eql char #\Newline) #\Return char)))
2682
2683(defun %private-ioblock-write-char-translating-newline-to-cr (ioblock char)
2684  (check-ioblock-owner ioblock)
2685  (%ioblock-write-char-translating-newline-to-cr ioblock char))
2686
2687(defun %locked-ioblock-write-char-translating-newline-to-cr (ioblock char)
2688  (with-ioblock-output-lock-grabbed (ioblock)
2689    (%ioblock-write-char-translating-newline-to-cr ioblock char)))
2690
2691(declaim (inline %ioblock-write-char-translating-newline-to-crlf))
2692(defun %ioblock-write-char-translating-newline-to-crlf (ioblock char)
2693  (when (eql char #\Newline)
2694    (funcall (ioblock-write-char-without-translation-when-locked-function
2695              ioblock)
2696             ioblock
2697             #\Return))   
2698  (funcall (ioblock-write-char-without-translation-when-locked-function
2699            ioblock)
2700           ioblock
2701           char))
2702
2703(defun %private-ioblock-write-char-translating-newline-to-crlf (ioblock char)
2704  (check-ioblock-owner ioblock)
2705  (%ioblock-write-char-translating-newline-to-crlf ioblock char))
2706
2707(defun %locked-ioblock-write-char-translating-newline-to-crlf (ioblock char)
2708  (with-ioblock-output-lock-grabbed (ioblock)
2709    (%ioblock-write-char-translating-newline-to-crlf ioblock char)))
2710
2711(declaim (inline %ioblock-write-char-translating-newline-to-line-separator))
2712(defun %ioblock-write-char-translating-newline-to-line-separator (ioblock char)
2713  (funcall (ioblock-write-char-without-translation-when-locked-function
2714            ioblock)
2715           ioblock
2716           (if (eql char #\Newline) #\Line_Separator char)))
2717
2718(defun %private-ioblock-write-char-translating-newline-to-line-separator (ioblock char)
2719  (check-ioblock-owner ioblock)
2720  (%ioblock-write-char-translating-newline-to-line-separator ioblock char))
2721
2722(defun %locked-ioblock-write-char-translating-newline-to-line-separator (ioblock char)
2723  (with-ioblock-output-lock-grabbed (ioblock)
2724    (%ioblock-write-char-translating-newline-to-line-separator ioblock char)))
2725
2726;;; If we do newline translation, we probably can't be too clever about reading/writing
2727;;; strings.
2728(defun %ioblock-write-simple-string-with-newline-translation (ioblock string start-pos num-chars)
2729  (declare (fixnum start-pos num-chars) (simple-string string))
2730  (let* ((col (ioblock-charpos ioblock))
2731         (wcf (ioblock-write-char-when-locked-function ioblock)))
2732    (declare (fixnum col))
2733    (do* ((i start-pos (1+ i))
2734          (n 0 (1+ n)))
2735         ((= n num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
2736      (let* ((char (schar string i)))
2737        (if (eql char #\Newline)
2738          (setq col 0)
2739          (incf col))
2740        (funcall wcf ioblock char)))))
2741
2742
2743;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2744
2745(defun setup-ioblock-input (ioblock character-p element-type sharing encoding line-termination)
2746  (setf (ioblock-sharing ioblock) sharing)
2747  (when character-p
2748    (setf (ioblock-unread-char-function ioblock) (select-stream-untyi-function (ioblock-stream ioblock) :input))
2749    (setf (ioblock-decode-literal-code-unit-limit ioblock)
2750          (if encoding
2751            (character-encoding-decode-literal-code-unit-limit encoding)
2752            256))   
2753    (if encoding
2754      (let* ((unit-size (character-encoding-code-unit-size encoding)))
2755        (setf (ioblock-peek-char-function ioblock) '%encoded-ioblock-peek-char)
2756        (setf (ioblock-read-line-function ioblock)
2757              '%ioblock-encoded-read-line)
2758        (setf (ioblock-character-read-vector-function ioblock)
2759              '%ioblock-encoded-character-read-vector)       
2760        (setf (ioblock-decode-input-function ioblock)
2761              (character-encoding-stream-decode-function encoding))
2762        (setf (ioblock-read-char-function ioblock)
2763              (ecase unit-size
2764                (8
2765                 (setf (ioblock-read-char-when-locked-function ioblock)
2766                       '%ioblock-read-u8-encoded-char)
2767                 (case sharing
2768                   (:private '%private-ioblock-read-u8-encoded-char)
2769                   (:lock '%locked-ioblock-read-u8-encoded-char)
2770                   (t '%ioblock-read-u8-encoded-char)))
2771                (16
2772                 (if (character-encoding-native-endianness encoding)
2773                   (progn
2774                    (setf (ioblock-read-char-when-locked-function ioblock)
2775                          '%ioblock-read-u16-encoded-char)
2776                    (case sharing
2777                      (:private '%private-ioblock-read-u16-encoded-char)
2778                      (:lock '%locked-ioblock-read-u16-encoded-char)
2779                      (t '%ioblock-read-u16-encoded-char)))
2780                   (progn
2781                     (setf (ioblock-read-char-when-locked-function ioblock)
2782                           '%ioblock-read-swapped-u16-encoded-char)
2783                    (case sharing
2784                      (:private '%private-ioblock-read-swapped-u16-encoded-char)
2785                      (:lock '%locked-ioblock-read-swapped-u16-encoded-char)
2786                      (t '%ioblock-read-swapped-u16-encoded-char)))))
2787                (32
2788                 (if (character-encoding-native-endianness encoding)
2789                   (progn
2790                    (setf (ioblock-read-char-when-locked-function ioblock)
2791                          #'%ioblock-read-u32-encoded-char)
2792                    (case sharing
2793                      (:private #'%private-ioblock-read-u32-encoded-char)
2794                      (:lock #'%locked-ioblock-read-u32-encoded-char)
2795                      (t #'%ioblock-read-u32-encoded-char)))
2796                   (progn
2797                     (setf (ioblock-read-char-when-locked-function ioblock)
2798                           #'%ioblock-read-swapped-u32-encoded-char)
2799                    (case sharing
2800                      (:private '#'%private-ioblock-read-swapped-u16-encoded-char)
2801                      (:lock #'%locked-ioblock-read-swapped-u32-encoded-char)
2802                      (t #'%ioblock-read-swapped-u32-encoded-char))))))))
2803      (progn
2804        (setf (ioblock-peek-char-function ioblock) '%ioblock-peek-char)
2805        (setf (ioblock-read-char-function ioblock)
2806              (case sharing
2807                (:private '%private-ioblock-tyi)
2808                (:lock '%locked-ioblock-tyi)
2809                (t '%ioblock-tyi)))
2810        (setf (ioblock-read-char-when-locked-function ioblock)
2811              '%ioblock-tyi)
2812        (setf (ioblock-character-read-vector-function ioblock)
2813              '%ioblock-unencoded-character-read-vector)
2814        (setf (ioblock-read-line-function ioblock)
2815              '%ioblock-unencoded-read-line)))
2816    (when line-termination
2817      (install-ioblock-input-line-termination ioblock line-termination))
2818    )
2819
2820  (unless (or (eq element-type 'character)
2821              (subtypep element-type 'character))
2822    (let* ((subtag (element-type-subtype element-type)))
2823      (declare (type (unsigned-byte 8) subtag))
2824      (setf (ioblock-read-byte-function ioblock)
2825            (cond ((= subtag target::subtag-u8-vector)
2826                   (if character-p
2827                     ;; The bivalent case, at least for now
2828                     (progn
2829                       (setf (ioblock-read-byte-when-locked-function ioblock)
2830                             '%bivalent-ioblock-read-u8-byte)
2831                       (case sharing
2832                         (:private '%bivalent-private-ioblock-read-u8-byte)
2833                         (:lock '%bivalent-locked-ioblock-read-u8-byte)
2834                         (t '%bivalent-ioblock-read-u8-byte)))
2835                     (progn
2836                       (setf (ioblock-read-byte-when-locked-function ioblock)
2837                             '%ioblock-read-u8-byte)
2838                       (case sharing
2839                         (:private '%private-ioblock-read-u8-byte)
2840                         (:lock '%locked-ioblock-read-u8-byte)
2841                         (t '%ioblock-read-u8-byte)))))
2842                  ((= subtag target::subtag-s8-vector)
2843                   (setf (ioblock-read-byte-when-locked-function ioblock)
2844                         '%ioblock-read-s8-byte) 
2845                   (case sharing
2846                     (:private '%private-ioblock-read-s8-byte)
2847                     (:lock '%locked-ioblock-read-s8-byte)
2848                     (t '%ioblock-read-s8-byte)))
2849                  ((= subtag target::subtag-u16-vector)
2850                   (setf (ioblock-read-byte-when-locked-function ioblock)
2851                         '%ioblock-read-u16-byte)
2852                   (case sharing
2853                     (:private '%private-ioblock-read-u16-byte)
2854                     (:lock '%locked-ioblock-read-u16-byte)
2855                     (t '%ioblock-read-u16-byte)))
2856                  ((= subtag target::subtag-s16-vector)
2857                   (setf (ioblock-read-byte-when-locked-function ioblock)
2858                         '%ioblock-read-s16-byte)
2859                   (case sharing
2860                     (:private '%private-ioblock-read-s16-byte)
2861                     (:lock '%locked-ioblock-read-s16-byte)
2862                     (t '%ioblock-read-s16-byte)))
2863                  ((= subtag target::subtag-u32-vector)
2864                   (setf (ioblock-read-byte-when-locked-function ioblock)
2865                         '%ioblock-read-u32-byte)
2866                   (case sharing
2867                     (:private '%private-ioblock-read-u32-byte)
2868                     (:lock '%locked-ioblock-read-u32-byte)
2869                     (t '%ioblock-read-u32-byte)))
2870                  ((= subtag target::subtag-s32-vector)
2871                   (setf (ioblock-read-byte-when-locked-function ioblock)
2872                         '%ioblock-read-s32-byte)                   
2873                   (case sharing
2874                     (:private '%private-ioblock-read-s32-byte)
2875                     (:lock '%locked-ioblock-read-s32-byte)
2876                     (t '%ioblock-read-s32-byte)))
2877                  #+64-bit-target
2878                  ((= subtag target::subtag-u64-vector)
2879                   (setf (ioblock-read-byte-when-locked-function ioblock)
2880                         '%ioblock-read-u64-byte)                   
2881                   (case sharing
2882                     (:private '%private-ioblock-read-u64-byte)
2883                     (:lock '%locked-ioblock-read-u64-byte)
2884                     (t '%ioblock-read-u64-byte)))
2885                  #+64-bit-target
2886                  ((= subtag target::subtag-s64-vector)
2887                   (setf (ioblock-read-byte-when-locked-function ioblock)
2888                         '%ioblock-read-s64-byte)
2889                   (case sharing
2890                     (:private '%private-ioblock-read-s64-byte)
2891                     (:lock '%locked-ioblock-read-s64-byte)
2892                     (t '%ioblock-read-s64-byte)))
2893                  ;; Not sure what this means, currently.
2894                  (t
2895                   (setf (ioblock-read-byte-when-locked-function ioblock)
2896                         '%general-ioblock-read-byte)
2897                   '%general-ioblock-read-byte))))))
2898
2899(defun install-ioblock-input-line-termination (ioblock line-termination)
2900  (when line-termination
2901    (let* ((sharing (ioblock-sharing ioblock)))
2902      (setf (ioblock-read-char-without-translation-when-locked-function ioblock)
2903            (ioblock-read-char-when-locked-function ioblock)
2904            (ioblock-character-read-vector-function ioblock)
2905            '%ioblock-encoded-character-read-vector
2906            (ioblock-read-line-function ioblock) '%ioblock-encoded-read-line)
2907      (ecase line-termination
2908        (:cr (setf (ioblock-read-char-when-locked-function ioblock)
2909                   '%ioblock-read-char-translating-cr-to-newline
2910                   (ioblock-read-char-function ioblock)
2911                   (case sharing
2912                     (:private
2913                      '%private-ioblock-read-char-translating-cr-to-newline)
2914                     (:lock
2915                      '%locked-ioblock-read-char-translating-cr-to-newline)
2916                     (t '%ioblock-read-char-translating-cr-to-newline))))
2917        (:crlf (setf (ioblock-read-char-when-locked-function ioblock)
2918                     '%ioblock-read-char-translating-crlf-to-newline
2919                     (ioblock-read-char-function ioblock)
2920                     (case sharing
2921                       (:private
2922                        '%private-ioblock-read-char-translating-crlf-to-newline)
2923                       (:lock
2924                        '%locked-ioblock-read-char-translating-crlf-to-newline)
2925                       (t '%ioblock-read-char-translating-crlf-to-newline))))
2926        (:unicode (setf (ioblock-read-char-when-locked-function ioblock)
2927                        '%ioblock-read-char-translating-line-separator-to-newline
2928                        (ioblock-read-char-function ioblock)
2929                        (case sharing
2930                          (:private
2931                           '%private-ioblock-read-char-translating-line-separator-to-newline)
2932                          (:lock
2933                           '%locked-ioblock-read-char-translating-line-separator-to-newline)
2934                          (t '%ioblock-read-char-translating-line-separator-to-newline)))))
2935      (setf (ioblock-line-termination ioblock) line-termination))))
2936 
2937(defun setup-ioblock-output (ioblock character-p element-type sharing encoding line-termination)
2938  (or (ioblock-sharing ioblock)
2939      (setf (ioblock-sharing ioblock) sharing))
2940  (when character-p
2941    (setf (ioblock-encode-literal-char-code-limit ioblock)
2942          (if encoding
2943            (character-encoding-encode-literal-char-code-limit encoding)
2944            256))   
2945    (if encoding
2946      (let* ((unit-size (character-encoding-code-unit-size encoding)))
2947        (setf (ioblock-encode-output-function ioblock)
2948              (character-encoding-stream-encode-function encoding))
2949        (setf (ioblock-write-char-function ioblock)
2950              (ecase unit-size
2951                (8
2952                 (setf (ioblock-write-char-when-locked-function ioblock)
2953                       '%ioblock-write-u8-encoded-char) 
2954                 (case sharing
2955                   (:private '%private-ioblock-write-u8-encoded-char)
2956                   (:lock '%locked-ioblock-write-u8-encoded-char)
2957                   (t '%ioblock-write-u8-encoded-char)))
2958                (16
2959                 (if (character-encoding-native-endianness encoding)
2960                   (progn
2961                     (setf (ioblock-write-char-when-locked-function ioblock)
2962                           '%ioblock-write-u16-encoded-char) 
2963                     (case sharing
2964                       (:private '%private-ioblock-write-u16-encoded-char)
2965                       (:lock '%locked-ioblock-write-u16-encoded-char)
2966                       (t '%ioblock-write-u16-encoded-char)))
2967                   (progn
2968                     (setf (ioblock-write-char-when-locked-function ioblock)
2969                           '%ioblock-write-swapped-u16-encoded-char)
2970                     (case sharing
2971                       (:private '%private-ioblock-write-swapped-u16-encoded-char)
2972                       (:lock '%locked-ioblock-write-swapped-u16-encoded-char)
2973                       (t '%ioblock-write-swapped-u16-encoded-char)))))
2974                (32
2975                 (if (character-encoding-native-endianness encoding)
2976                   (progn
2977                     (setf (ioblock-write-char-when-locked-function ioblock)
2978                           #'%ioblock-write-u32-encoded-char) 
2979                     (case sharing
2980                       (:private #'%private-ioblock-write-u32-encoded-char)
2981                       (:lock #'%locked-ioblock-write-u32-encoded-char)
2982                       (t #'%ioblock-write-u32-encoded-char)))
2983                   (progn
2984                     (setf (ioblock-write-char-when-locked-function ioblock)
2985                           #'%ioblock-write-swapped-u32-encoded-char)
2986                     (case sharing
2987                       (:private #'%private-ioblock-write-swapped-u32-encoded-char)
2988                       (:lock #'%locked-ioblock-write-swapped-u32-encoded-char)
2989                       (t #'%ioblock-write-swapped-u32-encoded-char)))))))
2990        (setf (ioblock-write-simple-string-function ioblock)
2991              (ecase unit-size
2992                (8 '%ioblock-write-u8-encoded-simple-string)
2993                (16
2994                 (if (character-encoding-native-endianness encoding)
2995                   '%ioblock-write-u16-encoded-simple-string
2996                   '%ioblock-write-swapped-u16-encoded-simple-string))
2997                (32
2998                 (if (character-encoding-native-endianness encoding)
2999                   #'%ioblock-write-u32-encoded-simple-string
3000                   #'%ioblock-write-swapped-u32-encoded-simple-string))))
3001        (when (character-encoding-use-byte-order-mark encoding)
3002          (setf (ioblock-pending-byte-order-mark ioblock) t)))
3003      (progn
3004        (setf (ioblock-write-simple-string-function ioblock)
3005              '%ioblock-unencoded-write-simple-string)
3006        (setf (ioblock-write-char-when-locked-function ioblock)
3007              '%ioblock-write-char)
3008        (setf (ioblock-write-char-function ioblock)
3009              (case sharing
3010                (:private '%private-ioblock-write-char)
3011                (:lock '%locked-ioblock-write-char)
3012                (t '%ioblock-write-char)))))
3013    (when line-termination
3014      (install-ioblock-output-line-termination ioblock line-termination)))
3015  (unless (or (eq element-type 'character)
3016              (subtypep element-type 'character))
3017    (let* ((subtag (element-type-subtype element-type)))
3018      (declare (type (unsigned-byte 8) subtag))
3019      (setf (ioblock-write-byte-function ioblock)
3020            (cond ((= subtag target::subtag-u8-vector)
3021                   (progn
3022                     (setf (ioblock-write-byte-when-locked-function ioblock)
3023                           '%ioblock-write-u8-byte)
3024                     (case sharing
3025                       (:private '%private-ioblock-write-u8-byte)
3026                       (:lock '%locked-ioblock-write-u8-byte)
3027                       (t '%ioblock-write-u8-byte))))
3028                  ((= subtag target::subtag-s8-vector)
3029                   (setf (ioblock-write-byte-when-locked-function ioblock)
3030                         '%ioblock-write-s8-byte)                   
3031                   (case sharing
3032                     (:private '%private-ioblock-write-s8-byte)
3033                     (:lock '%locked-ioblock-write-s8-byte)
3034                     (t '%ioblock-write-s8-byte)))
3035                  ((= subtag target::subtag-u16-vector)
3036                   (setf (ioblock-write-byte-when-locked-function ioblock)
3037                         '%ioblock-write-u16-byte)                   
3038                   (case sharing
3039                     (:private '%private-ioblock-write-u16-byte)
3040                     (:lock '%locked-ioblock-write-u16-byte)
3041                     (t '%ioblock-write-u16-byte)))
3042                  ((= subtag target::subtag-s16-vector)
3043                   (setf (ioblock-write-byte-when-locked-function ioblock)
3044                         '%ioblock-write-s16-byte)                                     
3045                   (case sharing
3046                     (:private '%private-ioblock-write-s16-byte)
3047                     (:lock '%locked-ioblock-write-s16-byte)
3048                     (t '%ioblock-write-s16-byte)))
3049                  ((= subtag target::subtag-u32-vector)
3050                   (setf (ioblock-write-byte-when-locked-function ioblock)
3051                         '%ioblock-write-u32-byte)                                     
3052                   (case sharing
3053                     (:private '%private-ioblock-write-u32-byte)
3054                     (:lock '%locked-ioblock-write-u32-byte)
3055                     (t '%ioblock-write-u32-byte)))
3056                  ((= subtag target::subtag-s32-vector)
3057                   (setf (ioblock-write-byte-when-locked-function ioblock)
3058                         '%ioblock-write-s32-byte)
3059                   (case sharing
3060                     (:private '%private-ioblock-write-s32-byte)
3061                     (:lock '%locked-ioblock-write-s32-byte)
3062                     (t '%ioblock-write-s32-byte)))
3063                  #+64-bit-target
3064                  ((= subtag target::subtag-u64-vector)
3065                   (setf (ioblock-write-byte-when-locked-function ioblock)
3066                         '%ioblock-write-u64-byte)
3067                   (case sharing
3068                     (:private '%private-ioblock-write-u64-byte)
3069                     (:lock '%locked-ioblock-write-u64-byte)
3070                     (t '%ioblock-write-u64-byte)))
3071                  #+64-bit-target
3072                  ((= subtag target::subtag-s64-vector)
3073                   (setf (ioblock-write-byte-when-locked-function ioblock)
3074                         '%ioblock-write-u64-byte)
3075                   (case sharing
3076                     (:private '%private-ioblock-write-s64-byte)
3077                     (:lock '%locked-ioblock-write-s64-byte)
3078                     (t '%ioblock-write-s64-byte)))
3079                  (t
3080                   (setf (ioblock-write-byte-when-locked-function ioblock)
3081                         '%general-ioblock-write-byte)                   
3082                   '%general-ioblock-write-byte))))))
3083
3084(defun install-ioblock-output-line-termination (ioblock line-termination)
3085  (let* ((sharing (ioblock-sharing ioblock)))
3086        (when line-termination
3087      (setf (ioblock-write-char-without-translation-when-locked-function ioblock)
3088            (ioblock-write-char-when-locked-function ioblock)
3089            (ioblock-write-simple-string-function ioblock)
3090            '%ioblock-write-simple-string-with-newline-translation)
3091      (ecase line-termination
3092        (:cr (setf (ioblock-write-char-when-locked-function ioblock)
3093                   '%ioblock-write-char-translating-newline-to-cr
3094                   (ioblock-read-char-function ioblock)
3095                   (case sharing
3096                     (:private
3097                      '%private-ioblock-write-char-translating-newline-to-cr)
3098                     (:lock
3099                      '%locked-ioblock-write-char-translating-newline-to-cr)
3100                     (t '%ioblock-write-char-translating-newline-to-cr))))
3101        (:crlf (setf (ioblock-write-char-when-locked-function ioblock)
3102                     '%ioblock-write-char-translating-newline-to-crlf
3103                     (ioblock-write-char-function ioblock)
3104                     (case sharing
3105                       (:private
3106                        '%private-ioblock-write-char-translating-newline-to-crlf)
3107                       (:lock
3108                        '%locked-ioblock-write-char-translating-newline-to-crlf)
3109                       (t '%ioblock-write-char-translating-newline-to-crlf))))
3110        (:unicode (setf (ioblock-write-char-when-locked-function ioblock)
3111                        '%ioblock-write-char-translating-newline-to-line-separator
3112                        (ioblock-write-char-function ioblock)
3113                        (case sharing
3114                          (:private
3115                           '%private-ioblock-write-char-translating-newline-to-line-separator)
3116                          (:lock
3117                           '%locked-ioblock-write-char-translating-newline-to-line-separator)
3118                          (t '%ioblock-write-char-translating-newline-to-line-separator)))))
3119      (setf (ioblock-line-termination ioblock) line-termination))))
3120
3121
3122(defun ensure-reasonable-element-type (element-type)
3123  (let* ((upgraded (upgraded-array-element-type element-type)))
3124    (if (eq upgraded 'bit)
3125      '(unsigned-byte 8)
3126      (if (eq upgraded 'fixnum)
3127        #+64-bit-target '(signed-byte 64) #+32-bit-target '(signed-byte 32)
3128        (if (eq upgraded t)
3129          (error "Stream element-type ~s can't be reasonably supported." element-type)
3130          upgraded)))))
3131
3132(defun init-stream-ioblock (stream
3133                            &key
3134                            insize      ; integer to allocate inbuf here, nil
3135                                        ; otherwise
3136                            outsize     ; integer to allocate outbuf here, nil
3137                                        ; otherwise
3138                            share-buffers-p ; true if input and output
3139                                        ; share a buffer
3140                            element-type
3141                            device
3142                            advance-function
3143                            listen-function
3144                            eofp-function
3145                            force-output-function
3146                            close-function
3147                            element-shift
3148                            interactive
3149                            (sharing :private)
3150                            character-p
3151                            encoding
3152                            line-termination
3153                            input-timeout
3154                            output-timeout
3155                            deadline
3156                            &allow-other-keys)
3157  (declare (ignorable element-shift))
3158  (setq line-termination (cdr (assoc line-termination *canonical-line-termination-conventions*)))
3159  (when encoding
3160    (unless (typep encoding 'character-encoding)
3161      (setq encoding (get-character-encoding encoding)))
3162    (if (eq encoding (get-character-encoding nil))
3163      (setq encoding nil)))
3164  (when sharing
3165    (unless (or (eq sharing :private)
3166                (eq sharing :lock))
3167      (if (eq sharing :external)
3168        (setq sharing nil)
3169        (report-bad-arg sharing '(member nil :private :lock :external)))))
3170  (let* ((ioblock (or (let* ((ioblock (stream-ioblock stream nil)))
3171                        (when ioblock
3172                          (setf (ioblock-stream ioblock) stream)
3173                          ioblock))
3174                      (stream-create-ioblock stream))))
3175    (when (eq sharing :private)
3176      (setf (ioblock-owner ioblock) 0))
3177    (setf (ioblock-encoding ioblock) encoding)
3178    (when insize
3179      (unless (ioblock-inbuf ioblock)
3180        (multiple-value-bind (buffer ptr in-size-in-octets)
3181            (make-heap-ivector insize
3182                               (if character-p
3183                                 '(unsigned-byte 8)
3184                                 (setq element-type
3185                                       (ensure-reasonable-element-type element-type))))
3186          (setf (ioblock-inbuf ioblock)
3187                (make-io-buffer :buffer buffer
3188                                :bufptr ptr
3189                                :size in-size-in-octets
3190                                :limit insize))
3191          (when (eq sharing :lock)
3192            (setf (ioblock-inbuf-lock ioblock) (make-lock)))
3193          (setf (ioblock-line-termination ioblock) line-termination)
3194
3195          (setf (ioblock-element-shift ioblock)
3196                (let* ((octets-per-element (/ in-size-in-octets insize)))
3197                  (case octets-per-element
3198                    (1 0)
3199                    (2 1)
3200                    (4 2)
3201                    (8 3)
3202                    (t (max 0 (ceiling (log octets-per-element 2)))))))
3203          )))
3204    (when (ioblock-inbuf ioblock)
3205      (setup-ioblock-input ioblock character-p element-type sharing encoding line-termination))     
3206    (if share-buffers-p
3207      (if insize
3208        (progn (setf (ioblock-outbuf ioblock)
3209                     (ioblock-inbuf ioblock))
3210               (setf (ioblock-outbuf-lock ioblock)
3211                     (ioblock-inbuf-lock ioblock)))
3212        (error "Can't share buffers unless insize is non-zero and non-null"))
3213      (when outsize
3214        (unless (ioblock-outbuf ioblock)
3215          (multiple-value-bind (buffer ptr out-size-in-octets)
3216              (make-heap-ivector outsize
3217                                 (if character-p
3218                                   '(unsigned-byte 8)
3219                                   (setq element-type (ensure-reasonable-element-type element-type))))
3220            (setf (ioblock-outbuf ioblock)
3221                  (make-io-buffer :buffer buffer
3222                                  :bufptr ptr
3223                                  :count 0
3224                                  :limit outsize
3225                                  :size out-size-in-octets))
3226            (when (eq sharing :lock)
3227              (setf (ioblock-outbuf-lock ioblock) (make-lock)))
3228            (setf (ioblock-element-shift ioblock)
3229                  (let* ((octets-per-element (/ out-size-in-octets outsize)))
3230                    (case octets-per-element
3231                      (1 0)
3232                      (2 1)
3233                      (4 2)
3234                      (8 3)
3235                      (t 
3236                       (max 0 (ceiling (log octets-per-element 2)))))))
3237            ))))
3238    (when (ioblock-outbuf ioblock)
3239      (setup-ioblock-output ioblock character-p element-type sharing encoding line-termination))
3240    (when element-type
3241      (setf (ioblock-element-type ioblock) (if character-p 'character element-type)))
3242;    (when element-shift
3243;      (setf (ioblock-element-shift ioblock) element-shift))
3244    (when device
3245      (setf (ioblock-device ioblock) device))
3246    (when advance-function
3247      (setf (ioblock-advance-function ioblock) advance-function))
3248    (when listen-function
3249      (setf (ioblock-listen-function ioblock) listen-function))
3250    (when eofp-function
3251      (setf (ioblock-eofp-function ioblock) eofp-function))
3252    (when force-output-function
3253      (setf (ioblock-force-output-function ioblock) force-output-function))
3254    (when close-function
3255      (setf (ioblock-close-function ioblock) close-function))
3256    (when interactive
3257      (setf (ioblock-interactive ioblock) interactive))
3258    (setf (stream-ioblock stream) ioblock)
3259    (when encoding
3260      (setf (ioblock-native-byte-order ioblock)
3261            (character-encoding-native-endianness encoding)))
3262    (let* ((bom-info (and insize encoding (character-encoding-use-byte-order-mark encoding))))
3263      (when bom-info
3264        (ioblock-check-input-bom ioblock bom-info sharing)))
3265    (setf (ioblock-input-timeout ioblock) input-timeout)
3266    (setf (ioblock-output-timeout ioblock) output-timeout)
3267    (setf (ioblock-deadline ioblock) deadline)
3268    ioblock))
3269
3270;;; If there's a byte-order-mark (or a reversed byte-order-mark) at
3271;;; the beginning of the input stream, deal with it.  If there's any
3272;;; input present, make sure that we don't write a BOM on output.  If
3273;;; this is a little-endian machine, input data was present, and there
3274;;; was no BOM in that data, make things big-endian.  If there's a
3275;;; leading BOM or swapped BOM, eat it (consume it so that it doesn't
3276;;; ordinarily appear as input.)
3277;;;
3278(defun ioblock-check-input-bom (ioblock swapped-encoding-name sharing)
3279  (let* ((n (%ioblock-advance ioblock nil))) ; try to read, don't block
3280    (when n
3281      (setf (ioblock-pending-byte-order-mark ioblock) nil)
3282      (let* ((inbuf (ioblock-inbuf ioblock))
3283             (unit-size (character-encoding-code-unit-size (ioblock-encoding ioblock)))
3284             (min (ash unit-size -3))
3285             (buf (io-buffer-buffer inbuf))
3286             (swapped-encoding
3287              (and
3288               (>= n min)
3289               (case (case unit-size
3290                       (16 (%native-u8-ref-u16 buf 0))
3291                       (32 (%native-u8-ref-u32 buf 0)))
3292                 (#.byte-order-mark-char-code
3293                  (setf (io-buffer-idx inbuf) min)
3294                  nil)
3295                 (#.swapped-byte-order-mark-char-code
3296                  (setf (io-buffer-idx inbuf) min)
3297                  t)
3298                 (t #+little-endian-target t))
3299               (lookup-character-encoding swapped-encoding-name))))
3300        (when swapped-encoding
3301          (let* ((output-p (not (null (ioblock-outbuf ioblock)))))
3302            (setf (ioblock-native-byte-order ioblock)
3303                  (character-encoding-native-endianness swapped-encoding))
3304            (ecase unit-size
3305              (16
3306               (setf (ioblock-read-char-when-locked-function ioblock)
3307                     '%ioblock-read-swapped-u16-encoded-char)
3308               (case sharing
3309                 (:private '%private-ioblock-read-swapped-u16-encoded-char)
3310                 (:lock '%locked-ioblock-read-swapped-u16-encoded-char)
3311                 (t '%ioblock-read-swapped-u16-encoded-char)))
3312              (32
3313               (setf (ioblock-read-char-when-locked-function ioblock)
3314                     '%ioblock-read-swapped-u32-encoded-char)
3315               (case sharing
3316                 (:private '%private-ioblock-read-swapped-u32-encoded-char)
3317                 (:lock '%locked-ioblock-read-swapped-u32-encoded-char)
3318                 (t '%ioblock-read-swapped-u16-encoded-char))))
3319            (when output-p
3320              (ecase unit-size
3321                (16
3322                 (setf (ioblock-write-char-when-locked-function ioblock)
3323                       '%ioblock-write-swapped-u16-encoded-char)
3324                 (case sharing
3325                   (:private '%private-ioblock-write-swapped-u16-encoded-char)
3326                   (:lock '%locked-ioblock-write-swapped-u16-encoded-char)
3327                   (t '%ioblock-write-swapped-u16-encoded-char))
3328                 (setf (ioblock-write-simple-string-function ioblock)
3329                       '%ioblock-write-swapped-u16-encoded-simple-string))
3330                (32
3331                 (setf (ioblock-write-char-when-locked-function ioblock)
3332                       '%ioblock-write-swapped-u32-encoded-char)
3333                 (case sharing
3334                   (:private '%private-ioblock-write-swapped-u32-encoded-char)
3335                   (:lock '%locked-ioblock-write-swapped-u32-encoded-char)
3336                   (t '%ioblock-write-swapped-u32-encoded-char))
3337                 (setf (ioblock-write-simple-string-function ioblock)
3338                       '%ioblock-write-swapped-u32-encoded-simple-string))))))))))
3339
3340
3341
3342;;; We can't define a MAKE-INSTANCE method on STRUCTURE-CLASS subclasses
3343;;; in MCL; of course, calling the structure-class's constructor does
3344;;; much the same thing (but note that MCL only keeps track of the
3345;;; default, automatically generated constructor.)
3346;;; (As fascinating as that may be, that has nothing to do with any
3347;;; nearby code, though it may have once been relevant.)
3348(defun make-ioblock-stream (class
3349                            &rest initargs
3350                            &key 
3351                            &allow-other-keys)
3352  (declare (dynamic-extent initargs))
3353  (let* ((s
3354          (if (subtypep class 'basic-stream)
3355            (apply #'make-basic-stream-instance class :allow-other-keys t initargs)
3356            (apply #'make-instance class :allow-other-keys t initargs))))
3357    (apply #'init-stream-ioblock s initargs)
3358    s))
3359
3360
3361
3362
3363
3364(defmethod select-stream-class ((s symbol) in-p out-p char-p)
3365  (select-stream-class (class-prototype (find-class s)) in-p out-p char-p))
3366
3367(defmethod select-stream-class ((s structure-class) in-p out-p char-p)
3368  (select-stream-class (class-prototype s) in-p out-p char-p))
3369
3370(defmethod select-stream-class ((s standard-class) in-p out-p char-p)
3371  (select-stream-class (class-prototype s) in-p out-p char-p))
3372
3373
3374(defparameter *canonical-line-termination-conventions*
3375  '((:unix . nil)
3376    (:macos . :cr)
3377    (:cr . :cr)
3378    (:crlf . :crlf)
3379    (:cp/m . :crlf)
3380    (:msdos . :crlf)
3381    (:dos . :crlf)
3382    (:windows . :crlf)
3383    (:inferred . nil)
3384    (:unicode . :unicode)))
3385
3386(defun optimal-buffer-size (fd element-type)
3387  #+windows-target (declare (ignore fd))
3388  (flet ((scale-buffer-size (octets)
3389           (case (subtag-bytes (element-type-subtype element-type) 1)
3390             (1 octets)
3391             (2 (ash octets -1))
3392             (4 (ash octets -2))
3393             (8 (ash octets -3)))))
3394    #+windows-target
3395    (let ((octets 4096))
3396      (scale-buffer-size octets))
3397    #-windows-target
3398    (let* ((nominal (or (nth-value 6 (%fstat fd)) *elements-per-buffer*))
3399           (octets (case (%unix-fd-kind fd)
3400                     (:pipe (#_fpathconf fd #$_PC_PIPE_BUF))
3401                     (:socket
3402                      #+linux-target nominal
3403                      #-linux-target
3404                      (int-getsockopt fd #$SOL_SOCKET
3405                                      #+solaris-target #$SO_SNDBUF
3406                                      #-solaris-target #$SO_SNDLOWAT))
3407                     ((:character-special :tty)
3408                      (#_fpathconf fd #$_PC_MAX_INPUT))
3409                     (t nominal))))
3410      (when (<= octets 0) (setq octets nominal))
3411      (scale-buffer-size octets))))
3412
3413(defun milliseconds-until-deadline (deadline ioblock)
3414  (let* ((now (get-internal-real-time)))
3415    (if (> now deadline)
3416      (error 'communication-deadline-expired :stream (ioblock-stream ioblock))
3417      (values (round (- deadline now) (/ internal-time-units-per-second 1000))))))
3418
3419
3420;;; Note that we can get "bivalent" streams by specifiying :character-p t
3421;;; with a reasonable element-type (e.g. (UNSIGNED-BYTE 8))
3422(defun make-fd-stream (fd &key
3423                          (direction :input)
3424                          (interactive t)
3425                          (element-type 'character)
3426                          (class 'fd-stream)
3427                          (sharing :private)
3428                          (character-p (or (eq element-type 'character)
3429                                           (subtypep element-type 'character)))
3430                          (basic nil)
3431                          encoding
3432                          line-termination
3433                          auto-close
3434                          input-timeout
3435                          output-timeout
3436                          deadline)
3437  (let* ((elements-per-buffer (optimal-buffer-size fd element-type)))
3438    (when line-termination
3439      (setq line-termination
3440            (cdr (assoc line-termination *canonical-line-termination-conventions*))))
3441    (when basic
3442      (setq class (map-to-basic-stream-class-name class))
3443      (setq basic (subtypep (find-class class) 'basic-stream)))
3444    (let* ((in-p (member direction '(:io :input)))
3445           (out-p (member direction '(:io :output)))
3446           (class-name (select-stream-class class in-p out-p character-p))
3447           (class (find-class class-name))
3448           (stream
3449            (make-ioblock-stream class
3450                                 :insize (if in-p elements-per-buffer)
3451                                 :outsize (if out-p elements-per-buffer)
3452                                 :device fd
3453                                 :interactive interactive
3454                                 :element-type element-type
3455                                 :advance-function (if in-p
3456                                                     (select-stream-advance-function class direction))
3457                                 :listen-function (if in-p 'fd-stream-listen)
3458                                 :eofp-function (if in-p 'fd-stream-eofp)
3459                                 :force-output-function (if out-p
3460                                                          (select-stream-force-output-function class direction))
3461                                 :close-function 'fd-stream-close
3462                                 :sharing sharing
3463                                 :character-p character-p
3464                                 :encoding encoding
3465                                 :line-termination line-termination
3466                                 :input-timeout input-timeout
3467                                 :output-timeout output-timeout
3468                                 :deadline deadline)))
3469      (if auto-close
3470        (terminate-when-unreachable stream
3471                                    (lambda (stream)
3472                                      (close-for-termination stream t))))
3473      stream)))
3474
3475 
3476;;;  Fundamental streams.
3477
3478(defclass fundamental-stream (stream)
3479    ())
3480
3481(defclass fundamental-input-stream (fundamental-stream input-stream)
3482    ((shared-resource :initform nil :accessor input-stream-shared-resource)))
3483
3484(defclass fundamental-output-stream (fundamental-stream output-stream)
3485    ())
3486
3487(defmethod input-stream-p ((x t))
3488  (report-bad-arg x 'stream))
3489                           
3490(defmethod input-stream-p ((s input-stream))
3491  t)
3492
3493(defmethod output-stream-p ((x t))
3494  (report-bad-arg x 'stream))
3495
3496(defmethod output-stream-p ((s input-stream))
3497  (typep s 'output-stream))
3498
3499(defmethod output-stream-p ((s output-stream))
3500  t)
3501
3502(defmethod input-stream-p ((s output-stream))
3503  (typep s 'input-stream))
3504
3505(defclass binary-stream (stream)
3506    ())
3507
3508(defclass character-stream (stream)
3509    ())
3510
3511(defmethod stream-external-format ((s character-stream))
3512  (make-external-format :character-encoding #+big-endian-target :utf-32be #+little-endian-target :utf-32le :line-termination :unix))
3513
3514
3515(defmethod (setf stream-external-format) (new (s character-stream))
3516  (check-type new external-format)
3517  (stream-external-format s))
3518
3519
3520(defclass fundamental-character-stream (fundamental-stream character-stream)
3521    ())
3522
3523(defmethod stream-element-type ((s fundamental-character-stream))
3524  'character)
3525
3526(defclass fundamental-binary-stream (fundamental-stream binary-stream)
3527    ())
3528
3529(defclass character-input-stream (input-stream character-stream)
3530    ())
3531
3532(defclass fundamental-character-input-stream (fundamental-input-stream
3533                                              fundamental-character-stream
3534                                              character-input-stream)
3535    ())
3536
3537(defmethod stream-read-char-no-hang ((s fundamental-character-input-stream))
3538  (stream-read-char s))
3539
3540(defmethod stream-peek-char ((s fundamental-character-input-stream))
3541  (let* ((ch (stream-read-char s)))
3542    (unless (eq ch :eof)
3543      (stream-unread-char s ch))
3544    ch))
3545
3546(defmethod stream-listen ((s fundamental-character-input-stream))
3547  (let* ((ch (stream-read-char-no-hang s)))
3548    (when (and ch (not (eq ch :eof)))
3549      (stream-unread-char s ch))
3550    ch))
3551
3552(defmethod stream-clear-input ((s fundamental-character-input-stream))
3553  )
3554
3555(defmethod stream-read-line ((s character-input-stream))
3556  (generic-read-line s))
3557
3558(defclass character-output-stream (output-stream character-stream)
3559    ())
3560
3561(defclass fundamental-character-output-stream (fundamental-output-stream
3562                                               fundamental-character-stream
3563                                               character-output-stream)
3564    ())
3565
3566(defclass binary-input-stream (input-stream binary-stream)
3567    ())
3568
3569(defclass fundamental-binary-input-stream (fundamental-input-stream
3570                                           fundamental-binary-stream
3571                                           binary-input-stream)
3572    ())
3573
3574(defclass binary-output-stream (output-stream binary-stream)
3575    ())
3576
3577(defclass fundamental-binary-output-stream (fundamental-output-stream
3578                                            fundamental-binary-stream
3579                                            binary-output-stream)
3580    ())
3581
3582
3583
3584(defmethod stream-read-byte ((s t))
3585  (report-bad-arg s '(and input-stream binary-stream)))
3586
3587(defmethod stream-write-byte ((s t) b)
3588  (declare (ignore b))
3589  (report-bad-arg s '(and output-stream binary-stream)))
3590
3591(defmethod stream-length ((s stream) &optional new)
3592  (declare (ignore new)))
3593
3594(defmethod stream-start-line-p ((s character-output-stream))
3595  (eql 0 (stream-line-column s)))
3596
3597(defmethod stream-terpri ((s character-output-stream))
3598  (stream-write-char s #\Newline))
3599
3600(defmethod stream-fresh-line ((s character-output-stream))
3601  (unless (stream-start-line-p s)
3602    (stream-terpri s)
3603    t))
3604
3605;;; The bad news is that this doesn't even bother to do the obvious
3606;;; (calling STREAM-WRITE-STRING with a longish string of spaces.)
3607;;; The good news is that this method is pretty useless to (format "~T" ...)
3608;;; anyhow.
3609(defmethod stream-advance-to-column ((s fundamental-character-output-stream)
3610                                     col)
3611  (generic-advance-to-column s col))
3612
3613(defmethod stream-write-string ((stream fundamental-character-output-stream) string &optional (start 0) end)
3614  (generic-stream-write-string stream string start end))
3615
3616
3617;;; The read-/write-vector methods could be specialized for stream classes
3618;;; that expose the underlying buffering mechanism.
3619;;; They can assume that the 'vector' argument is a simple one-dimensional
3620;;; array and that the 'start' and 'end' arguments are sane.
3621
3622(defmethod stream-write-vector ((stream character-output-stream)
3623                                vector start end)
3624  (declare (fixnum start end))
3625  (do* ((i start (1+ i)))
3626       ((= i end))
3627    (declare (fixnum i))
3628    (write-char (uvref vector i) stream)))
3629
3630(defmethod stream-write-vector ((stream binary-output-stream)
3631                                vector start end)
3632  (declare (fixnum start end))
3633  (do* ((i start (1+ i)))
3634       ((= i end))
3635    (declare (fixnum i))
3636    (write-byte (uvref vector i) stream)))
3637
3638(defmethod stream-read-vector ((stream character-input-stream)
3639                               vector start end)
3640  (generic-character-read-vector stream vector start end))
3641
3642
3643(defmethod stream-read-vector ((stream binary-input-stream)
3644                               vector start end)
3645  (declare (fixnum start end))
3646  (do* ((i start (1+ i)))
3647       ((= i end) end)
3648    (declare (fixnum i))
3649    (let* ((b (read-byte stream nil :eof)))
3650      (if (eq b :eof)
3651        (return i)
3652        (setf (uvref vector i) b)))))
3653
3654
3655
3656
3657;;; File streams, in the abstract.
3658
3659(defclass file-stream (stream)
3660    ())
3661
3662(defmethod stream-domain ((s file-stream))
3663  :file)
3664
3665
3666
3667;;; "Basic" (non-extensible) streams.
3668
3669
3670(declaim (inline basic-stream-p))
3671
3672(defun basic-stream-p (x)
3673  (= (the fixnum (typecode x)) target::subtag-basic-stream))
3674
3675(setf (type-predicate 'basic-stream) 'basic-stream-p)
3676
3677(make-built-in-class 'basic-stream 'stream)
3678(make-built-in-class 'basic-file-stream 'basic-stream 'file-stream)
3679(make-built-in-class 'basic-character-stream 'basic-stream 'character-stream)
3680(make-built-in-class 'basic-binary-stream 'basic-stream 'binary-stream)
3681
3682(make-built-in-class 'basic-input-stream 'basic-stream 'input-stream)
3683(make-built-in-class 'basic-output-stream 'basic-stream 'output-stream)
3684(make-built-in-class 'basic-io-stream 'basic-input-stream 'basic-output-stream)
3685(make-built-in-class 'basic-character-input-stream 'basic-input-stream 'basic-character-stream 'character-input-stream)
3686(make-built-in-class 'basic-character-output-stream 'basic-output-stream 'basic-character-stream 'character-output-stream)
3687(make-built-in-class 'basic-character-io-stream 'basic-character-input-stream 'basic-character-output-stream)
3688(make-built-in-class 'basic-binary-input-stream 'basic-input-stream 'basic-binary-stream 'binary-input-stream)
3689(make-built-in-class 'basic-binary-output-stream 'basic-output-stream 'basic-binary-stream 'binary-output-stream)
3690(make-built-in-class 'basic-binary-io-stream 'basic-binary-input-stream 'basic-binary-output-stream)
3691
3692
3693(defun %ioblock-external-format (ioblock)
3694  (let* ((encoding (or (ioblock-encoding ioblock)
3695                       (get-character-encoding nil)))
3696         (line-termination (or (ioblock-line-termination ioblock)
3697                               :unix)))
3698    (make-external-format :character-encoding (character-encoding-name encoding)
3699                          :line-termination line-termination)))
3700
3701(defmethod input-stream-shared-resource ((s basic-input-stream))
3702  (getf (basic-stream.info s) :shared-resource))
3703
3704(defmethod (setf input-stream-shared-resource) (new (s basic-input-stream))
3705  (setf (getf (basic-stream.info s) :shared-resource) new))
3706
3707(defmethod print-object ((s basic-stream) out)
3708  (print-unreadable-object (s out :type t :identity t)
3709    (let* ((ioblock (basic-stream.state s))
3710           (fd (and ioblock (ioblock-device ioblock)))
3711           (encoding (and ioblock (encoding-name (ioblock-encoding ioblock)))))
3712      (if fd
3713        (format out "~a (~a/~d)" encoding (%unix-fd-kind fd) fd)
3714        (format out "~s" :closed)))))
3715
3716(defmethod select-stream-class ((s (eql 'basic-stream)) in-p out-p char-p)
3717  (if char-p
3718    (if in-p
3719      (if out-p
3720        'basic-character-io-stream
3721        'basic-character-input-stream)
3722      'basic-character-output-stream)
3723    (if in-p
3724      (if out-p
3725        'basic-binary-io-stream
3726        'basic-binary-input-stream)
3727      'basic-binary-output-stream)))
3728
3729
3730(defmethod map-to-basic-stream-class-name (name)
3731  name)
3732
3733(defmethod map-to-basic-stream-class-name ((name (eql 'fd-stream)))
3734  'basic-stream)
3735
3736(defun allocate-basic-stream (class)
3737  (if (subtypep class 'basic-file-stream)
3738    (gvector :basic-stream (%class-own-wrapper class) 0 nil nil nil nil nil)
3739    (gvector :basic-stream (%class-own-wrapper class) 0 nil nil)))
3740
3741
3742(defmethod initialize-basic-stream ((s basic-stream) &key &allow-other-keys)
3743  )
3744 
3745(defmethod initialize-basic-stream :after  ((s basic-input-stream) &key &allow-other-keys)
3746  (setf (basic-stream.flags s)
3747        (logior (ash 1 basic-stream-flag.open-input) (basic-stream.flags s))))
3748
3749(defmethod initialize-basic-stream :after ((s basic-output-stream) &key &allow-other-keys)
3750  (setf (basic-stream.flags s)
3751        (logior (ash 1 basic-stream-flag.open-output) (basic-stream.flags s))))
3752
3753(defmethod initialize-basic-stream :after ((s basic-binary-stream) &key &allow-other-keys)
3754  (setf (basic-stream.flags s)
3755        (logior (ash 1 basic-stream-flag.open-binary) (basic-stream.flags s))))
3756
3757(defmethod initialize-basic-stream :after ((s basic-character-stream) &key &allow-other-keys)
3758  (setf (basic-stream.flags s)
3759        (logior (ash 1 basic-stream-flag.open-character) (basic-stream.flags s))))
3760
3761(defun make-basic-stream-instance (class &rest initargs)
3762  (let* ((s (allocate-basic-stream class)))
3763    (apply #'initialize-basic-stream s initargs)
3764    s))
3765
3766
3767
3768(defmethod (setf stream-ioblock) (ioblock (s basic-stream))
3769  (setf (basic-stream.state s) ioblock))
3770
3771(defmethod stream-create-ioblock ((stream basic-stream) &rest args &key)
3772  (declare (dynamic-extent args))
3773  (apply #'make-ioblock :stream stream args))
3774
3775
3776(defmethod stream-write-list ((stream fundamental-character-output-stream)
3777                              list count)
3778  (declare (fixnum count))
3779  (dotimes (i count)
3780    (stream-write-char stream (pop list))))
3781
3782(defmethod stream-write-list ((stream basic-character-output-stream)
3783                              list count)
3784  (declare (fixnum count))
3785  (dotimes (i count)
3786    (stream-write-char stream (pop list))))
3787
3788(defmethod stream-read-list ((stream character-input-stream)
3789                             list count)
3790  (generic-character-read-list stream list count))
3791
3792
3793(defmethod stream-write-list ((stream fundamental-binary-output-stream)
3794                              list count)
3795  (declare (fixnum count))
3796  (dotimes (i count)
3797    (let* ((element (pop list)))
3798      (if (typep element 'character)
3799        (write-char element stream)
3800        (write-byte element stream)))))
3801
3802(defmethod stream-write-list ((stream basic-binary-output-stream)
3803                              list count)
3804  (declare (fixnum count))
3805  (dotimes (i count)
3806    (let* ((element (pop list)))
3807      (if (typep element 'character)
3808        (write-char element stream)
3809        (write-byte element stream)))))
3810
3811(defmethod stream-read-list ((stream binary-input-stream)
3812                             list count)
3813  (declare (fixnum count))
3814  (do* ((tail list (cdr tail))
3815        (i 0 (1+ i)))
3816       ((= i count) count)
3817    (declare (fixnum i))
3818    (let* ((b (read-byte stream nil :eof)))
3819      (if (eq b :eof)
3820        (return i)
3821        (rplaca tail b)))))
3822
3823
3824
3825(defun stream-is-closed (s)
3826  (error "~s is closed" s))
3827
3828(defmethod stream-read-char ((s basic-character-input-stream))
3829  (let* ((ioblock (basic-stream-ioblock s)))
3830    (funcall (ioblock-read-char-function ioblock) ioblock)))
3831
3832
3833(defmethod stream-read-char-no-hang ((stream basic-character-input-stream))
3834  (let* ((ioblock (basic-stream-ioblock stream)))
3835    (with-ioblock-input-locked (ioblock)
3836      (values
3837          (%ioblock-tyi-no-hang ioblock)))))
3838       
3839(defmethod stream-peek-char ((stream basic-character-input-stream))
3840  (let* ((ioblock (basic-stream-ioblock stream)))
3841    (with-ioblock-input-locked (ioblock)
3842      (values
3843       (funcall (ioblock-peek-char-function ioblock) ioblock)))))
3844
3845(defmethod stream-clear-input ((stream basic-character-input-stream))
3846  (let* ((ioblock (basic-stream-ioblock stream)))
3847    (with-ioblock-input-locked (ioblock)
3848      (values
3849        (%ioblock-clear-input ioblock)))))
3850
3851(defmethod stream-unread-char ((s basic-character-input-stream) char)
3852  (let* ((ioblock (basic-stream-ioblock s)))
3853    (with-ioblock-input-locked (ioblock)
3854      (values
3855       (funcall (ioblock-unread-char-function ioblock) ioblock char)))))
3856
3857(defmethod stream-read-ivector ((s basic-binary-input-stream)
3858                                iv start nb)
3859  (let* ((ioblock (basic-stream-ioblock s)))
3860    (with-ioblock-input-locked (ioblock)
3861      (values
3862       (%ioblock-binary-in-ivect ioblock iv start nb)))))
3863
3864(defmethod stream-read-vector ((stream basic-character-input-stream)
3865                               vector start end)
3866  (declare (fixnum start end))
3867  (if (not (typep vector 'simple-base-string))
3868    (generic-character-read-vector stream vector start end)
3869    (let* ((ioblock (basic-stream-ioblock stream)))
3870      (with-ioblock-input-locked (ioblock)
3871        (values
3872         (funcall (ioblock-character-read-vector-function ioblock)
3873                  ioblock vector start end))))))
3874
3875(defmethod stream-read-line ((stream basic-character-input-stream))
3876  (let* ((ioblock (basic-stream-ioblock stream)))
3877    (with-ioblock-input-locked (ioblock)
3878      (funcall (ioblock-read-line-function ioblock) ioblock))))
3879
3880                             
3881;;; Synonym streams.
3882
3883(defclass synonym-stream (fundamental-stream)
3884    ((symbol :initarg :symbol :reader synonym-stream-symbol)))
3885
3886(defmethod print-object ((s synonym-stream) out)
3887  (print-unreadable-object (s out :type t :identity t)
3888    (format out "to ~s" (synonym-stream-symbol s))))
3889
3890(macrolet ((synonym-method (name &rest args)
3891            (let* ((stream (make-symbol "STREAM")))
3892              `(defmethod ,name ((,stream synonym-stream) ,@args)
3893                (,name (symbol-value (synonym-stream-symbol ,stream)) ,@args)))))
3894           (synonym-method stream-read-char)
3895           (synonym-method stream-read-byte)
3896           (synonym-method stream-unread-char c)
3897           (synonym-method stream-read-char-no-hang)
3898           (synonym-method stream-peek-char)
3899           (synonym-method stream-listen)
3900           (synonym-method stream-eofp)
3901           (synonym-method stream-clear-input)
3902           (synonym-method stream-read-line)
3903           (synonym-method stream-read-list l c)
3904           (synonym-method stream-read-vector v start end)
3905           (synonym-method stream-write-char c)
3906           ;(synonym-method stream-write-string str &optional (start 0) end)
3907           (synonym-method stream-write-byte b)
3908           (synonym-method stream-clear-output)
3909           (synonym-method stream-line-column)
3910           (synonym-method stream-line-length)
3911           (synonym-method stream-set-column new)
3912           (synonym-method stream-advance-to-column new)
3913           (synonym-method stream-start-line-p)
3914           (synonym-method stream-fresh-line)
3915           (synonym-method stream-terpri)
3916           (synonym-method stream-force-output)
3917           (synonym-method stream-finish-output)
3918           (synonym-method stream-write-list l c)
3919           (synonym-method stream-write-vector v start end)
3920           (synonym-method stream-element-type)
3921           (synonym-method input-stream-p)
3922           (synonym-method output-stream-p)
3923           (synonym-method interactive-stream-p)
3924           (synonym-method stream-direction)
3925           (synonym-method stream-device direction)
3926           (synonym-method stream-surrounding-characters)
3927           (synonym-method stream-input-timeout)
3928           (synonym-method stream-output-timeout)
3929           (synonym-method stream-deadline)
3930           (synonym-method stream-eof-transient-p))
3931
3932(defmethod (setf input-stream-timeout) (new (s synonym-stream))
3933  (setf (input-stream-timeout (symbol-value (synonym-stream-symbol s))) new))
3934
3935(defmethod (setf output-stream-timeout) (new (s synonym-stream))
3936  (setf (output-stream-timeout (symbol-value (synonym-stream-symbol s))) new))
3937
3938
3939(defmethod stream-write-string ((s synonym-stream) string &optional (start 0) end)
3940  (stream-write-string (symbol-value (synonym-stream-symbol s)) string start end))
3941
3942(defmethod stream-length ((s synonym-stream) &optional new)
3943  (stream-length (symbol-value (synonym-stream-symbol s)) new))
3944
3945(defmethod stream-position ((s synonym-stream) &optional new)
3946  (stream-position (symbol-value (synonym-stream-symbol s)) new))
3947
3948(defun make-synonym-stream (symbol)
3949  (make-instance 'synonym-stream :symbol (require-type symbol 'symbol)))
3950
3951;;;
3952(defclass composite-stream-mixin ()
3953    ((open-p :initform t)))
3954
3955(defmethod close :after ((stream composite-stream-mixin) &key abort)
3956  (declare (ignore abort))
3957  (with-slots (open-p) stream
3958    (setq open-p nil)))
3959
3960(defmethod open-stream-p ((stream composite-stream-mixin))
3961  (slot-value stream 'open-p))
3962
3963
3964;;; Two-way streams.
3965(defclass two-way-stream (composite-stream-mixin fundamental-input-stream fundamental-output-stream)
3966    ((input-stream :initarg :input-stream :accessor two-way-stream-input-stream)
3967     (output-stream :initarg :output-stream :accessor two-way-stream-output-stream)))
3968
3969(defmethod stream-eof-transient-p ((stream two-way-stream))
3970  (stream-eof-transient-p (two-way-stream-input-stream stream)))
3971
3972(defmethod print-object ((s two-way-stream) out)
3973  (print-unreadable-object (s out :type t :identity t)
3974    (format out "input ~s, output ~s" 
3975            (two-way-stream-input-stream s)
3976            (two-way-stream-output-stream s))))
3977
3978(macrolet ((two-way-input-method (name &rest args)
3979             (let* ((stream (make-symbol "STREAM")))
3980               `(defmethod ,name ((,stream two-way-stream) ,@args)
3981                 (,name (two-way-stream-input-stream ,stream) ,@args))))
3982           (two-way-output-method (name &rest args)
3983             (let* ((stream (make-symbol "STREAM")))
3984               `(defmethod ,name ((,stream two-way-stream) ,@args)
3985                 (,name (two-way-stream-output-stream ,stream) ,@args)))))
3986  (two-way-input-method stream-read-char)
3987  (two-way-input-method stream-read-byte)
3988  (two-way-input-method stream-unread-char c)
3989  (two-way-input-method stream-read-char-no-hang)
3990  (two-way-input-method stream-peek-char)
3991  (two-way-input-method stream-listen)
3992  (two-way-input-method stream-eofp)
3993  (two-way-input-method stream-clear-input)
3994  (two-way-input-method stream-read-line)
3995  (two-way-input-method stream-read-list l c)
3996  (two-way-input-method stream-read-vector v start end)
3997  (two-way-input-method stream-surrounding-characters)
3998  (two-way-input-method stream-input-timeout)
3999  (two-way-input-method interactive-stream-p)
4000  (two-way-output-method stream-write-char c)
4001  (two-way-output-method stream-write-byte b)
4002  (two-way-output-method stream-clear-output)
4003  (two-way-output-method stream-line-column)
4004  (two-way-output-method stream-line-length)
4005  (two-way-output-method stream-set-column new)
4006  (two-way-output-method stream-advance-to-column new)
4007  (two-way-output-method stream-start-line-p)
4008  (two-way-output-method stream-fresh-line)
4009  (two-way-output-method stream-terpri)
4010  (two-way-output-method stream-force-output)
4011  (two-way-output-method stream-finish-output)
4012  (two-way-output-method stream-write-list l c)
4013  (two-way-output-method stream-write-vector v start end)
4014  (two-way-output-method stream-output-timeout)
4015  (two-way-output-method stream-deadline))
4016
4017(defmethod (setf stream-input-timeout) (new (s two-way-stream))
4018  (setf (stream-input-timeout (two-way-stream-input-stream s)) new))
4019
4020(defmethod (setf stream-output-timeout) (new (s two-way-stream))
4021  (setf (stream-output-timeout (two-way-stream-output-stream s)) new))
4022
4023(defmethod (setf stream-deadline) (new (s two-way-stream))
4024  (setf (stream-deadline (two-way-stream-output-stream s)) new))
4025
4026(defmethod stream-device ((s two-way-stream) direction)
4027  (case direction
4028    (:input (stream-device (two-way-stream-input-stream s) direction))
4029    (:output (stream-device (two-way-stream-output-stream s) direction))))
4030   
4031(defmethod stream-write-string ((s two-way-stream) string &optional (start 0) end)
4032  (stream-write-string (two-way-stream-output-stream s) string start end))
4033
4034(defmethod stream-element-type ((s two-way-stream))
4035  (let* ((in-type (stream-element-type (two-way-stream-input-stream s)))
4036         (out-type (stream-element-type (two-way-stream-output-stream s))))
4037    (if (equal in-type out-type)
4038      in-type
4039      `(and ,in-type ,out-type))))
4040
4041(defun make-two-way-stream (in out)
4042  "Return a bidirectional stream which gets its input from INPUT-STREAM and
4043   sends its output to OUTPUT-STREAM."
4044  (unless (input-stream-p in)
4045    (require-type in 'input-stream))
4046  (unless (output-stream-p out)
4047    (require-type out 'output-stream))
4048  (make-instance 'two-way-stream :input-stream in :output-stream out))
4049
4050;;; This is intended for use with things like *TERMINAL-IO*, where the
4051;;; OS echoes interactive input.  Whenever we read a character from
4052;;; the underlying input-stream of such a stream, we need to update
4053;;; our notion of the underlying output-stream's STREAM-LINE-COLUMN.
4054
4055(defclass echoing-two-way-stream (two-way-stream)
4056    ())
4057
4058(defmethod stream-read-char ((s echoing-two-way-stream))
4059  (let* ((out (two-way-stream-output-stream s))
4060         (in (two-way-stream-input-stream s)))
4061    (force-output out)
4062    (let* ((ch (stream-read-char in)))
4063      (unless (eq ch :eof)
4064        (if (eq ch #\newline)
4065          (stream-set-column out 0)
4066          (let* ((cur (stream-line-column out)))
4067            (when cur
4068              (stream-set-column out (1+ (the fixnum cur)))))))
4069      ch)))
4070
4071(defmethod stream-read-line ((s echoing-two-way-stream))
4072  (let* ((out (two-way-stream-output-stream s)))
4073    (force-output out)
4074    (multiple-value-bind (string eof)
4075        (call-next-method)
4076      (unless eof
4077        (stream-set-column out 0))
4078      (values string eof))))
4079
4080(defun make-echoing-two-way-stream (in out)
4081  (make-instance 'echoing-two-way-stream :input-stream in :output-stream out))
4082
4083;;;echo streams
4084
4085(defclass echo-stream (two-way-stream)
4086    ((did-untyi :initform nil)))
4087
4088(defmethod echo-stream-input-stream ((s echo-stream))
4089  (two-way-stream-input-stream s))
4090
4091(defmethod echo-stream-output-stream ((s echo-stream))
4092  (two-way-stream-output-stream s))
4093
4094(defmethod stream-read-char ((s echo-stream))
4095  (let* ((char (stream-read-char (echo-stream-input-stream s))))
4096    (unless (eq char :eof)
4097      (if (slot-value s 'did-untyi)
4098        (setf (slot-value s 'did-untyi) nil)
4099        (stream-write-char (echo-stream-output-stream s) char)))
4100    char))
4101
4102(defmethod stream-unread-char ((s echo-stream) c)
4103  (call-next-method s c)
4104  (setf (slot-value s 'did-untyi) c))
4105
4106(defmethod stream-read-char-no-hang ((s echo-stream))
4107  (let* ((char (stream-read-char-no-hang (echo-stream-input-stream s))))
4108    (unless (eq char :eof)
4109      (if (slot-value s 'did-untyi)
4110        (setf (slot-value s 'did-untyi) nil)
4111        (stream-write-char (echo-stream-output-stream s) char)))
4112    char))
4113
4114(defmethod stream-clear-input ((s echo-stream))
4115  (call-next-method)
4116  (setf (slot-value s 'did-untyi) nil))
4117
4118(defmethod stream-read-byte ((s echo-stream))
4119  (let* ((byte (stream-read-byte (echo-stream-input-stream s))))
4120    (unless (eq byte :eof)
4121      (stream-write-byte (echo-stream-output-stream s) byte))
4122    byte))
4123
4124(defmethod stream-read-line ((s echo-stream))
4125  (generic-read-line s))
4126
4127(defmethod stream-read-vector ((s echo-stream) vector start end)
4128  (if (subtypep (stream-element-type s) 'character)
4129      (generic-character-read-vector s vector start end)
4130    (generic-binary-read-vector s vector start end)))
4131
4132(defun make-echo-stream (input-stream output-stream)
4133  "Return a bidirectional stream which gets its input from INPUT-STREAM and
4134   sends its output to OUTPUT-STREAM. In addition, all input is echoed to
4135   the output stream."
4136  (make-instance 'echo-stream
4137                 :input-stream input-stream
4138                 :output-stream output-stream))
4139
4140;;;concatenated-streams
4141
4142(defclass concatenated-stream (composite-stream-mixin fundamental-input-stream)
4143    ((streams :initarg :streams :accessor concatenated-stream-streams)))
4144
4145
4146(defun concatenated-stream-current-input-stream (s)
4147  (car (concatenated-stream-streams s)))
4148
4149(defun concatenated-stream-next-input-stream (s)
4150  (setf (concatenated-stream-streams s)
4151        (cdr (concatenated-stream-streams s)))
4152  (concatenated-stream-current-input-stream s))
4153
4154(defmethod stream-element-type ((s concatenated-stream))
4155  (let* ((c (concatenated-stream-current-input-stream s)))
4156    (if c
4157      (stream-element-type c)
4158      nil)))
4159
4160
4161
4162(defmethod stream-read-char ((s concatenated-stream))
4163  (do* ((c (concatenated-stream-current-input-stream s)
4164           (concatenated-stream-next-input-stream s)))
4165       ((null c) :eof)
4166    (let* ((ch (stream-read-char c)))
4167      (unless (eq ch :eof)
4168        (return ch)))))
4169
4170(defmethod stream-read-char-no-hang ((s concatenated-stream))
4171  (do* ((c (concatenated-stream-current-input-stream s)
4172           (concatenated-stream-next-input-stream s)))
4173       ((null c) :eof)
4174    (let* ((ch (stream-read-char-no-hang c)))
4175      (unless (eq ch :eof)
4176        (return ch)))))
4177
4178(defmethod stream-read-byte ((s concatenated-stream))
4179  (do* ((c (concatenated-stream-current-input-stream s)
4180           (concatenated-stream-next-input-stream s)))
4181       ((null c) :eof)
4182    (let* ((b (stream-read-byte c)))
4183      (unless (eq b :eof)
4184        (return b)))))
4185
4186(defmethod stream-peek-char ((s concatenated-stream))
4187  (do* ((c (concatenated-stream-current-input-stream s)
4188       (concatenated-stream-next-input-stream s)))
4189       ((null c) :eof)
4190    (let* ((ch (stream-peek-char c)))
4191      (unless (eq ch :eof)
4192        (return ch)))))
4193
4194(defmethod stream-read-line ((s concatenated-stream))
4195  (generic-read-line s))
4196
4197(defmethod stream-read-list ((s concatenated-stream) list count)
4198  (generic-character-read-list s list count))
4199
4200(defmethod stream-read-vector ((s concatenated-stream) vector start end)
4201  (if (subtypep (stream-element-type s) 'character)
4202      (generic-character-read-vector s vector start end)
4203    (generic-binary-read-vector s vector start end)))
4204
4205(defmethod stream-unread-char ((s concatenated-stream) char)
4206  (let* ((c (concatenated-stream-current-input-stream s)))
4207    (if c
4208      (stream-unread-char c char))))
4209
4210(defmethod stream-listen ((s concatenated-stream))
4211  (do* ((c (concatenated-stream-current-input-stream s)
4212           (concatenated-stream-next-input-stream s)))
4213       ((null c))
4214    (when (stream-listen c)
4215      (return t))))
4216
4217(defmethod stream-eofp ((s concatenated-stream))
4218  (do* ((c (concatenated-stream-current-input-stream s)
4219           (concatenated-stream-next-input-stream s)))
4220       ((null c) t)
4221    (when (stream-listen c)
4222      (return nil))))
4223
4224(defmethod stream-clear-input ((s concatenated-stream))
4225  (let* ((c (concatenated-stream-current-input-stream s)))
4226    (when c (stream-clear-input c))))
4227
4228
4229(defun make-concatenated-stream (&rest streams)
4230  "Return a stream which takes its input from each of the streams in turn,
4231   going on to the next at EOF."
4232  (dolist (s streams (make-instance 'concatenated-stream :streams streams))
4233    (unless (input-stream-p s)
4234      (error "~S is not an input stream" s))))
4235
4236;;;broadcast-streams
4237
4238
4239
4240(defclass broadcast-stream (fundamental-output-stream)
4241    ((streams :initarg :streams :reader broadcast-stream-streams)))
4242
4243(macrolet ((broadcast-method
4244               (op (stream &rest others )
4245                   &optional
4246                   (args (cons stream others)))
4247             (let* ((sub (gensym))
4248                    (result (gensym)))
4249               `(defmethod ,op ((,stream broadcast-stream) ,@others)
4250                 (let* ((,result nil))
4251                   (dolist (,sub (broadcast-stream-streams ,stream) ,result)
4252                             (setq ,result (,op ,@(cons sub (cdr args))))))))))
4253             (broadcast-method stream-write-char (s c))
4254             (broadcast-method stream-write-string
4255                                      (s str &optional (start 0) end)
4256                                      (s str start end))
4257             (broadcast-method stream-write-byte (s b))
4258             (broadcast-method stream-clear-output (s))
4259             (broadcast-method stream-line-column (s))
4260             (broadcast-method stream-set-column (s new))
4261             (broadcast-method stream-advance-to-column (s new))
4262             (broadcast-method stream-start-line-p (s))
4263             (broadcast-method stream-terpri (s))
4264             (broadcast-method stream-force-output (s))
4265             (broadcast-method stream-finish-output (s))
4266             (broadcast-method stream-write-list (s l c))
4267             (broadcast-method stream-write-vector (s v start end)))
4268
4269(defun last-broadcast-stream (s)
4270  (car (last (broadcast-stream-streams s))))
4271
4272(defmethod stream-fresh-line ((s broadcast-stream))
4273  (let* ((did-output-newline nil))
4274    (dolist (sub (broadcast-stream-streams s) did-output-newline)
4275      (setq did-output-newline (stream-fresh-line sub)))))
4276
4277(defmethod stream-element-type ((s broadcast-stream))
4278  (let* ((last (last-broadcast-stream s)))
4279    (if last
4280      (stream-element-type last)
4281      t)))
4282
4283(defmethod stream-length ((s broadcast-stream) &optional new)
4284  (unless new
4285    (let* ((last (last-broadcast-stream s)))
4286      (if last
4287        (stream-length last)
4288        0))))
4289
4290(defmethod stream-position ((s broadcast-stream) &optional new)
4291  (unless new
4292    (let* ((last (last-broadcast-stream s)))
4293      (if last
4294        (stream-position last)
4295        0))))
4296
4297(defun make-broadcast-stream (&rest streams)
4298  (dolist (s streams (make-instance 'broadcast-stream :streams streams))
4299    (unless (output-stream-p s)
4300      (report-bad-arg s '(satisfies output-stream-p)))))
4301
4302
4303
4304;;; String streams.
4305(make-built-in-class 'string-stream 'basic-character-stream)
4306
4307(defmethod print-object ((s string-stream) out)
4308  (print-unreadable-object (s out :type t :identity t)
4309    (unless (open-stream-p s)  (format out " ~s" :closed))))
4310
4311
4312                 
4313
4314(defstruct (string-stream-ioblock (:include ioblock))
4315  string)
4316
4317(defstruct (string-output-stream-ioblock (:include string-stream-ioblock))
4318  (index 0)
4319  freelist
4320  (line-length 80))
4321
4322(defstatic *string-output-stream-class* (make-built-in-class 'string-output-stream 'string-stream 'basic-character-output-stream))
4323(defstatic *string-output-stream-class-wrapper* (%class-own-wrapper *string-output-stream-class*))
4324
4325(defstatic *fill-pointer-string-output-stream-class* (make-built-in-class 'fill-pointer-string-output-stream 'string-output-stream))
4326
4327(def-standard-initial-binding %string-output-stream-ioblocks% (%cons-pool nil))
4328
4329(defmethod stream-force-output ((s string-output-stream))
4330  nil)
4331
4332(defmethod stream-finish-output ((s string-output-stream))
4333  nil)
4334
4335(defmethod stream-clear-output ((s string-output-stream))
4336  nil)
4337
4338(defmethod stream-line-length ((s string-output-stream))
4339  (let* ((ioblock (basic-stream-ioblock s)))
4340    (string-output-stream-ioblock-line-length ioblock)))
4341
4342(defmethod (setf stream-line-length) (newlen (s string-output-stream))
4343  (let* ((ioblock (basic-stream-ioblock s)))
4344    (setf (string-output-stream-ioblock-line-length ioblock) newlen)))
4345
4346
4347;;; Should only be used for a stream whose class is exactly
4348;;; *string-output-stream-class*
4349(defun %close-string-output-stream (stream ioblock)
4350  (let* ((pool %string-output-stream-ioblocks%))
4351    (when (and pool
4352               (eq (basic-stream.wrapper stream)
4353                   *string-output-stream-class-wrapper*)
4354               (eq (string-output-stream-ioblock-freelist ioblock) pool))
4355      (without-interrupts
4356       (setf (ioblock-stream ioblock) (pool.data pool)
4357             (pool.data pool) ioblock)))))
4358
4359;;; If this is the sort of string stream whose ioblock we recycle and
4360;;; there's a thread-local binding of the variable we use for a freelist,
4361;;; return the value of that binding.
4362(defun %string-stream-ioblock-freelist (stream)
4363  (and stream
4364       (eq (basic-stream.wrapper stream)
4365           *string-output-stream-class-wrapper*)
4366       (let* ((loc (%tcr-binding-location (%current-tcr) '%string-output-stream-ioblocks%)))
4367         (and loc (%fixnum-ref loc)))))
4368
4369
4370(defun create-string-output-stream-ioblock (stream string write-char-function write-string-function)
4371  (let* ((recycled (and stream
4372                        (eq (basic-stream.wrapper stream)
4373                            *string-output-stream-class-wrapper*)
4374                        (without-interrupts
4375                         (let* ((data (pool.data %string-output-stream-ioblocks%)))
4376                           (when data
4377                             (setf (pool.data %string-output-stream-ioblocks%)
4378                                   (ioblock-stream data)
4379                                   (ioblock-stream data) stream
4380                                   (ioblock-device data) -1
4381                                   (ioblock-charpos data) 0
4382                                   (string-output-stream-ioblock-index data) 0
4383                                   (string-output-stream-ioblock-line-length data) 80))
4384                           data)))))
4385    (or recycled
4386        (make-string-output-stream-ioblock :stream stream
4387                                           :string string
4388                                           :element-type 'character
4389                                           :write-char-function write-char-function
4390                                           :write-char-when-locked-function write-char-function
4391                                           :write-simple-string-function write-string-function
4392                                           :force-output-function #'false
4393                                           :freelist (%string-stream-ioblock-freelist stream)
4394                                           :close-function #'%close-string-output-stream
4395                                           :device -1))))
4396                       
4397
4398
4399(defun %%make-string-output-stream (class string write-char-function write-string-function)
4400  (let* ((stream (gvector :basic-stream (%class.own-wrapper class)
4401                          (logior (ash 1 basic-stream-flag.open-character)
4402                                  (ash 1 basic-stream-flag.open-output))
4403                          nil
4404                          nil))
4405         (ioblock (create-string-output-stream-ioblock stream string write-char-function write-string-function)))
4406      (setf (basic-stream.state stream) ioblock)
4407      stream))
4408
4409(declaim (inline %string-push-extend))
4410(defun %string-push-extend (char string)
4411  (let* ((fill (%svref string target::vectorH.logsize-cell))
4412         (size (%svref string target::vectorH.physsize-cell)))
4413    (declare (fixnum fill size))
4414    (if (< fill size)
4415      (multiple-value-bind (data offset) (array-data-and-offset string)
4416        (declare (simple-string data) (fixnum offset))
4417        (setf (schar data (the fixnum (+ offset fill))) char
4418              (%svref string target::vectorH.logsize-cell) (the fixnum (1+ fill))))
4419      (vector-push-extend char string))))
4420             
4421
4422(defun fill-pointer-string-output-stream-ioblock-write-char (ioblock char)
4423  ;; can do better (maybe much better) than VECTOR-PUSH-EXTEND here.
4424  (if (eql char #\Newline)
4425    (setf (ioblock-charpos ioblock) 0)
4426    (incf (ioblock-charpos ioblock)))
4427  (%string-push-extend char (string-stream-ioblock-string ioblock)))
4428
4429(defun fill-pointer-string-output-stream-ioblock-write-simple-string (ioblock string start-char num-chars)
4430</