source: branches/working-0710/ccl/level-1/l1-streams.lisp @ 7422

Last change on this file since 7422 was 7422, checked in by gb, 12 years ago

Default STREAM-SURROUNDING-CHARACTERS specialized on T (for SOCKET-ERROR
on non-streams, like LISTENER-SOCKETs).

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