source: branches/working-0711/ccl/level-1/l1-streams.lisp @ 7733

Last change on this file since 7733 was 7733, checked in by gb, 13 years ago

Reformat a comment.

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