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

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

Takehiko Abe's fix to %IOBLOCK-WRITE-U16-ENCODED-CHAR.

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