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

Last change on this file since 7468 was 7468, checked in by palter, 14 years ago

Just close the stream (with :ABORT T) in the finalizer for :AUTO-CLOSE T.
(The previous finalizer was broken; I don't know how it ever worked.)

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