source: release/1.3/source/level-1/l1-streams.lisp @ 11831

Last change on this file since 11831 was 11831, checked in by gb, 10 years ago

r11827 (Windows I/O timeouts) to 1.3.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 228.5 KB
RevLine 
[6]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
[2326]18(in-package "CCL")
[11135]19
[6]20;;;
21
22(defclass stream ()
[4893]23  ())
[6]24
[4907]25
[478]26(defclass input-stream (stream)
[4907]27  ())
[478]28
[4907]29
[6]30(defclass output-stream (stream) ())
31
[4893]32(defmethod stream-direction ((s stream))
33  )
34
[5360]35(defmethod stream-domain ((s stream))
36  t)
37
38
[4893]39(defmethod stream-direction ((s input-stream))
40  (if (typep s 'output-stream)
41    :io
42    :input))
43
44(defmethod stream-direction ((s output-stream))
45  (if (typep s 'input-stream)
46    :io
47    :output))
48
[8486]49(defun check-io-timeout (timeout)
50  (when timeout
51    (require-type timeout '(real 0 1000000))))
52
53(defmethod stream-input-timeout ((s input-stream))
54  nil)
55
56(defmethod (setf input-stream-timeout) (new (s input-stream))
57  (check-io-timeout new))
58
59(defmethod stream-output-timeout ((s output-stream))
60  nil)
61
62(defmethod (setf stream-output-timeout) (new (s output-stream))
63  (check-io-timeout new))
64
[6633]65;;; Try to return a string containing characters that're near the
66;;; stream's current position, if that makes sense.  Return NIL
67;;; if it doesn't make sense.
[7733]68;;; Some things (SOCKET-ERRORs) are signaled as STREAM-ERRORs
69;;; whose STREAM args aren't streams.  That's wrong, but
70;;; defining this method on T keeps things from blowing up worse.
[7444]71(defmethod stream-surrounding-characters ((s t))
72  (declare (ignore s))
[6633]73  nil)
[4893]74
[6633]75
[6]76;;; The "direction" argument only helps us dispatch on two-way streams:
77;;; it's legal to ask for the :output device of a stream that's only open
78;;; for input, and one might get a non-null answer in that case.
79(defmethod stream-device ((s stream) direction)
80  (declare (ignore direction)))
81
82;;; Some generic stream functions:
[441]83(defmethod stream-length ((x t) &optional new)
84  (declare (ignore new))
85  (report-bad-arg x 'stream))
[6]86
[441]87(defmethod stream-position ((x t) &optional new)
88  (declare (ignore new))
89  (report-bad-arg x 'stream))
90
91(defmethod stream-element-type ((x t))
92  (report-bad-arg x 'stream))
93
[9886]94(defmethod stream-force-output ((x t))
95  (report-bad-arg x 'stream))
96
[5582]97(defmethod stream-position ((s stream) &optional newpos)
98  (declare (ignore newpos)))
99
[6]100;;; For input streams:
101
102;; From Shannon Spires, slightly modified.
103(defun generic-read-line (s)
104  (let* ((str (make-array 20 :element-type 'base-char
105                          :adjustable t :fill-pointer 0))
106         (eof nil))
107    (do* ((ch (read-char s nil :eof) (read-char s nil :eof)))
108         ((or (eq ch #\newline) (setq eof (eq ch :eof)))
109          (values (ensure-simple-string str) eof))
110      (vector-push-extend ch str))))
111
112(defun generic-character-read-list (stream list count)
113  (declare (fixnum count))
114  (do* ((tail list (cdr tail))
115        (i 0 (1+ i)))
116       ((= i count) count)
117    (declare (fixnum i))
118    (let* ((ch (read-char stream nil :eof)))
119      (if (eq ch :eof)
120        (return i)
121        (rplaca tail ch)))))
122
123(defun generic-binary-read-list (stream list count)
124  (declare (fixnum count))
125  (do* ((tail list (cdr tail))
126        (i 0 (1+ i)))
127       ((= i count) count)
128    (declare (fixnum i))
129    (let* ((ch (stream-read-byte stream)))
130      (if (eq ch :eof)
131        (return i)
132        (rplaca tail ch)))))
133
134(defun generic-character-read-vector (stream vector start end)
135  (declare (fixnum start end))
136  (do* ((i start (1+ i)))
137       ((= i end) end)
138    (declare (fixnum i))
139    (let* ((ch (stream-read-char stream)))
140      (if (eq ch :eof)
141        (return i)
142        (setf (uvref vector i) ch)))))
143
144(defun generic-binary-read-vector (stream vector start end)
145  (declare (fixnum start end))
146  (do* ((i start (1+ i)))
147       ((= i end) end)
148    (declare (fixnum i))
149    (let* ((byte (stream-read-byte stream)))
150      (if (eq byte :eof)
151        (return i)
152        (setf (uvref vector i) byte)))))
153
154
155;;; For output streams:
156
157(defun generic-advance-to-column (s col)
158  (let* ((current (column s)))
159    (unless (null current)
160      (when (< current col)
161        (do* ((i current (1+ i)))
162             ((= i col))
163          (write-char #\Space s)))
164      t)))
165
166
167
168(defun generic-stream-write-string (stream string start end)
169  (setq end (check-sequence-bounds string start end))
170  (locally (declare (fixnum start end))
171    (multiple-value-bind (vect offset) (array-data-and-offset string)
172      (declare (fixnum offset))
173      (unless (zerop offset)
174        (incf start offset)
175        (incf end offset))
176      (do* ((i start (1+ i)))
177           ((= i end) string)
178        (declare (fixnum i))
179        (write-char (schar vect i) stream)))))
180
181
182
183
184
185
186
187
188
[85]189
190
191
[6]192(defloadvar *heap-ivectors* ())
[885]193(defvar *heap-ivector-lock* (make-lock))
[6]194
[885]195
[962]196
197(defun %make-heap-ivector (subtype size-in-bytes size-in-elts)
[1667]198  (with-macptrs ((ptr (malloc (+ size-in-bytes
[3964]199                                 #+32-bit-target (+ 4 2 7) ; 4 for header, 2 for delta, 7 for round up
200                                 #+64-bit-target (+ 8 2 15) ; 8 for header, 2 for delta, 15 for round up
[1667]201                                 ))))
[6]202    (let ((vect (fudge-heap-pointer ptr subtype size-in-elts))
203          (p (%null-ptr)))
204      (%vect-data-to-macptr vect p)
[885]205      (with-lock-grabbed (*heap-ivector-lock*)
206        (push vect *heap-ivectors*))
[6]207      (values vect p))))
208
[885]209(defun %heap-ivector-p (v)
210  (with-lock-grabbed (*heap-ivector-lock*)
211    (not (null (member v *heap-ivectors* :test #'eq)))))
[6]212
213
[885]214(defun dispose-heap-ivector (v)
215  (if (%heap-ivector-p v)
[6]216    (with-macptrs (p)
[885]217      (with-lock-grabbed (*heap-ivector-lock*)
218        (setq *heap-ivectors* (delq v *heap-ivectors*)))
[6]219      (%%make-disposable p v)
220      (free p))))
221
[885]222(defun %dispose-heap-ivector (v)
223  (dispose-heap-ivector v))
[6]224
[885]225(defun make-heap-ivector (element-count element-type)
226  (let* ((subtag (ccl::element-type-subtype element-type)))
[1537]227    (unless
228        #+ppc32-target
229        (= (logand subtag ppc32::fulltagmask)
230               ppc32::fulltag-immheader)
231        #+ppc64-target
232        (= (logand subtag ppc64::lowtagmask)
233           ppc64::lowtag-immheader)
[10131]234        #+x8632-target
235        (= (logand subtag x8632::fulltagmask)
236           x8632::fulltag-immheader)
[3964]237        #+x8664-target
238        (logbitp (the (mod 16) (logand subtag x8664::fulltagmask))
239                 (logior (ash 1 x8664::fulltag-immheader-0)
240                         (ash 1 x8664::fulltag-immheader-1)
241                         (ash 1 x8664::fulltag-immheader-2)))
[885]242      (error "~s is not an ivector subtype." element-type))
243    (let* ((size-in-octets (ccl::subtag-bytes subtag element-count)))
244      (multiple-value-bind (pointer vector)
245          (ccl::%make-heap-ivector subtag size-in-octets element-count)
246        (values pointer vector size-in-octets)))))
[6]247
248
249
250
251
[85]252
253
254
[885]255
[6]256(defvar *elements-per-buffer* 2048)  ; default buffer size for file io
257
258(defmethod streamp ((x t))
259  nil)
260
261(defmethod streamp ((x stream))
262  t)
263
[424]264(defmethod stream-io-error ((stream stream) error-number context)
265  (error 'simple-stream-error :stream stream
266         :format-control (format nil "~a during ~a"
267                                 (%strerror error-number) context)))
[6]268
269
270
271(defmethod stream-write-char ((stream stream) char)
272  (declare (ignore char))
273  (error "stream ~S is not capable of output" stream))
274
275(defun stream-write-entire-string (stream string)
276  (stream-write-string stream string))
277
[462]278
279(defmethod stream-read-char ((x t))
280  (report-bad-arg x 'stream))
281
[6]282(defmethod stream-read-char ((stream stream))
283  (error "~s is not capable of input" stream))
284
[462]285(defmethod stream-unread-char ((x t) char)
286  (declare (ignore char))
287  (report-bad-arg x 'stream))
288
[6]289(defmethod stream-unread-char ((stream stream) char)
290  (declare (ignore char))
291  (error "stream ~S is not capable of input" stream))
292
293
294
295(defmethod stream-force-output ((stream output-stream)) nil)
296(defmethod stream-maybe-force-output ((stream stream))
297  (stream-force-output stream))
298
299(defmethod stream-finish-output ((stream output-stream)) nil)
300
[441]301
302
[6]303(defmethod stream-clear-output ((stream output-stream)) nil)
304
305(defmethod close ((stream stream) &key abort)
306  (declare (ignore abort))
[4895]307  (open-stream-p stream))
[6]308
[9831]309(defmethod close-for-termination ((stream stream) abort)
310  (close stream :abort abort))
[6]311
[384]312
[358]313(defmethod open-stream-p ((x t))
314  (report-bad-arg x 'stream))
315
[6]316(defmethod open-stream-p ((stream stream))
[4893]317  t)
[6]318
[5354]319(defmethod stream-external-format ((x t))
320  (report-bad-arg x 'stream))
321
322(defmethod stream-external-format ((s stream))
323  nil)
324
325
326(defmethod (setf stream-external-format) (new (s t))
[5413]327  (normalize-external-format (stream-domain s) new)
[5354]328  (report-bad-arg s 'stream))
329
330
331
332   
[6]333(defmethod stream-fresh-line ((stream output-stream))
334  (terpri stream)
335  t)
336
337(defmethod stream-line-length ((stream stream))
338  "This is meant to be shadowed by particular kinds of streams,
339   esp those associated with windows."
340  80)
341
[358]342(defmethod interactive-stream-p ((x t))
343  (report-bad-arg x 'stream))
344
[6]345(defmethod interactive-stream-p ((stream stream)) nil)
346
[441]347(defmethod stream-clear-input ((x t))
348  (report-bad-arg x 'stream))
[5354]349
[6]350(defmethod stream-clear-input ((stream input-stream)) nil)
351
352(defmethod stream-listen ((stream input-stream))
353  (not (eofp stream)))
354
[298]355(defmethod stream-filename ((stream stream))
356  (report-bad-arg stream 'file-stream))
[6]357
358
359
360
361;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
362
363;;; For input streams, the IO-BUFFER-COUNT field denotes the number
364;;; of elements read from the underlying input source (e.g., the
365;;; file system.)  For output streams, it's the high-water mark of
366;;; elements output to the buffer.
367
368(defstruct io-buffer
[9240]369               ;; This type is too complex during bootstrapping.
370  (buffer nil #|:type (or (simple-array * (*)) null)|#)
[6]371  (bufptr nil :type (or macptr null))
372  (size 0 :type fixnum)                 ; size (in octets) of buffer
373  (idx 0 :type fixnum)                  ; index of next element
374  (count 0 :type fixnum)                ; count of active elements
375  (limit 0 :type fixnum)                ; size (in elements) of buffer
[5306]376  (translate nil)                       ; newline-translation
[6]377  )
378
379(defmethod print-object ((buf io-buffer) out)
380  (print-unreadable-object (buf out :identity t :type t)
381    (let* ((buffer (io-buffer-buffer buf)))
382      (when buffer (format out " ~s " (array-element-type buffer))))
383    (format out "~d/~d/~d"
384            (io-buffer-idx buf)
385            (io-buffer-count buf)
386            (io-buffer-limit buf))))
387
388(defstruct ioblock
389  stream                                ; the stream being buffered
390  untyi-char                            ; nil or last value passed to
391                                        ;  stream-unread-char
392  (inbuf nil :type (or null io-buffer))
393  (outbuf nil :type (or null io-buffer))
394  (element-type 'character)
395  (element-shift 0 :type fixnum)        ;element shift count
[9240]396  (charpos 0 :type (or null fixnum))     ;position of cursor
397  (device -1 :type (or null fixnum))     ;file descriptor
[6]398  (advance-function 'ioblock-advance)
399  (listen-function 'ioblock-listen)
400  (eofp-function 'ioblock-eofp)
401  (force-output-function 'ioblock-force-output)
402  (close-function 'ioblock-close)
403  (inbuf-lock nil)
404  (eof nil)
405  (interactive nil)
406  (dirty nil)
[4885]407  (outbuf-lock nil)
[4893]408  (owner nil)
409  (read-char-function 'ioblock-no-char-input)
410  (read-byte-function 'ioblock-no-binary-input)
[4920]411  (write-byte-function 'ioblock-no-binary-output)
[4893]412  (write-char-function 'ioblock-no-char-output)
[4920]413  (encoding nil)
[5256]414  (pending-byte-order-mark nil)
[6538]415  (decode-literal-code-unit-limit 256)
[5192]416  (encode-output-function nil)
417  (decode-input-function nil)
[5226]418  (read-char-when-locked-function 'ioblock-no-char-input)
[5202]419  (write-simple-string-function 'ioblock-no-char-output)
420  (character-read-vector-function 'ioblock-no-char-input)
421  (read-line-function 'ioblock-no-char-input)
[5226]422  (write-char-when-locked-function 'ioblock-no-char-output)
423  (read-byte-when-locked-function 'ioblock-no-binary-input)
424  (write-byte-when-locked-function 'ioblock-no-binary-output)
[5245]425  (peek-char-function 'ioblock-no-char-input)
[5264]426  (native-byte-order t)
[5329]427  (read-char-without-translation-when-locked-function 'ioblock-no-char-input)
428  (write-char-without-translation-when-locked-function 'iblock-no-char-output)
[5319]429  (sharing nil)
[5354]430  (line-termination nil)
[5398]431  (unread-char-function 'ioblock-no-char-input)
[6538]432  (encode-literal-char-code-limit 256)
[8486]433  (input-timeout nil)
[8596]434  (output-timeout nil)
435  (deadline nil))
[6]436
437
438;;; Functions on ioblocks.  So far, we aren't saying anything
439;;; about how streams use them.
440
[5202]441(defun ioblock-no-binary-input (ioblock &rest otters)
442  (declare (ignore otters))
[4893]443  (report-bad-arg (ioblock-stream ioblock) '(and binary-stream input-stream)))
[6]444
[5202]445(defun ioblock-no-binary-output (ioblock &rest others)
446  (declare (ignore others))
[4893]447  (report-bad-arg (ioblock-stream ioblock) '(and binary-stream output-stream)))
448
[5245]449(defun ioblock-no-char-input (ioblock &rest others)
[5202]450  (declare (ignore others))
[4893]451  (report-bad-arg (ioblock-stream ioblock) '(and character-stream input-stream)))
452
[5329]453(defun ioblock-no-char-output (ioblock &rest others)
454  (declare (ignore others))
[4893]455  (report-bad-arg (ioblock-stream ioblock) '(and character-stream output-stream)))
456
457
[6]458(defun ioblock-octets-to-elements (ioblock octets)
459  (let* ((shift (ioblock-element-shift ioblock)))
460    (declare (fixnum shift))
461    (if (zerop shift)
462      octets
463      (ash octets (- shift)))))
464
465(defun ioblock-elements-to-octets (ioblock elements)
466  (let* ((shift (ioblock-element-shift ioblock)))
467    (declare (fixnum shift))
468    (if (zerop shift)
469      elements
470      (ash elements shift))))
471
472
473
[4890]474;;; ioblock must really be an ioblock or you will crash
475;;; Also: the expression "ioblock" is evaluated multiple times.
476
477(declaim (inline check-ioblock-owner))
478(defun check-ioblock-owner (ioblock)
[4918]479  (declare (optimize (speed 3)))
[4890]480  (let* ((owner (ioblock-owner ioblock)))
481    (if owner
482      (or (eq owner *current-process*)
483          (error "Stream ~s is private to ~s" (ioblock-stream ioblock) owner)))))
484
485
[4895]486
[5192]487(declaim (inline %ioblock-advance))
[6]488(defun %ioblock-advance (ioblock read-p)
489  (funcall (ioblock-advance-function ioblock)
490           (ioblock-stream ioblock)
491           ioblock
492           read-p))
[4901]493
[6]494
[6633]495(defun %ioblock-surrounding-characters (ioblock)
496  (let* ((inbuf (ioblock-inbuf ioblock)))
497    (when inbuf
498      (let* ((encoding (or (ioblock-encoding ioblock)
499                           (get-character-encoding nil)))
500             (size (ash (character-encoding-code-unit-size encoding) -3))
501             (buffer (io-buffer-buffer inbuf))
502             (idx (io-buffer-idx inbuf))
503             (count (io-buffer-count inbuf)))
504        (unless (= count 0)
[10424]505          (let* ((start (max (- idx (* 10 size)) 0))
506                 (end (min (+ idx (* 10 size)) count))
[6633]507                 (string (make-string (funcall (character-encoding-length-of-vector-encoding-function encoding) buffer start end))))
508            (funcall (character-encoding-vector-decode-function encoding)
509                     buffer
510                     start
511                     (- end start)
512                     string)
513            (if (position #\Replacement_Character string)
514              (string-trim (string #\Replacement_Character) string)
515              string)))))))
516             
517       
[4918]518
[6]519
[4918]520(defun %bivalent-ioblock-read-u8-byte (ioblock)
[4901]521  (declare (optimize (speed 3) (safety 0)))
[5427]522  (setf (ioblock-untyi-char ioblock) nil)
[5390]523  (let* ((buf (ioblock-inbuf ioblock))
524         (idx (io-buffer-idx buf))
525         (limit (io-buffer-count buf)))
526    (declare (fixnum idx limit))
527    (when (= idx limit)
528      (unless (%ioblock-advance ioblock t)
529        (return-from %bivalent-ioblock-read-u8-byte :eof))
530      (setq idx (io-buffer-idx buf)
531            limit (io-buffer-count buf)))
532    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
533    (aref (the (simple-array (unsigned-byte 8) (*))
534              (io-buffer-buffer buf)) idx)))
[4901]535
[5192]536
537(declaim (inline %ioblock-read-u8-byte))
[4918]538(defun %ioblock-read-u8-byte (ioblock)
[4901]539  (declare (optimize (speed 3) (safety 0)))
[4918]540  (let* ((buf (ioblock-inbuf ioblock))
541         (idx (io-buffer-idx buf))
542         (limit (io-buffer-count buf)))
543    (declare (fixnum idx limit))
544    (when (= idx limit)
545      (unless (%ioblock-advance ioblock t)
546        (return-from %ioblock-read-u8-byte :eof))
[5319]547      (setq idx (io-buffer-idx buf)))
548    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
549    (aref (the (simple-array (unsigned-byte 8) (*))
550            (io-buffer-buffer buf)) idx)))
551
552(declaim (inline %ioblock-read-u8-code-unit))
553(defun %ioblock-read-u8-code-unit (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-u8-code-unit :eof))
[4918]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 8) (*))
[5319]566              (io-buffer-buffer buf)) idx)))             
[4918]567
[5208]568(declaim (inline %ioblock-read-s8-byte))
569(defun %ioblock-read-s8-byte (ioblock)
570  (declare (optimize (speed 3) (safety 0)))
571  (let* ((buf (ioblock-inbuf ioblock))
572         (idx (io-buffer-idx buf))
573         (limit (io-buffer-count buf)))
574    (declare (fixnum idx limit))
575    (when (= idx limit)
576      (unless (%ioblock-advance ioblock t)
577        (return-from %ioblock-read-s8-byte :eof))
578      (setq idx (io-buffer-idx buf)
579            limit (io-buffer-count buf)))
580    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
581    (aref (the (simple-array (signed-byte 8) (*))
582            (io-buffer-buffer buf)) idx)))
583
[5212]584(defun %private-ioblock-read-s8-byte (ioblock)
585  (declare (optimize (speed 3) (safety 0)))
586  (check-ioblock-owner ioblock)
587  (%ioblock-read-s8-byte ioblock))
588
589(defun %locked-ioblock-read-s8-byte (ioblock)
590  (declare (optimize (speed 3) (safety 0)))
591  (with-ioblock-input-lock-grabbed (ioblock)
592    (%ioblock-read-s8-byte ioblock)))
593
594
[5202]595(declaim (inline %ioblock-read-u16-byte))
596(defun %ioblock-read-u16-byte (ioblock)
597  (declare (optimize (speed 3) (safety 0)))
598  (let* ((buf (ioblock-inbuf ioblock))
599         (idx (io-buffer-idx buf))
600         (limit (io-buffer-count buf)))
601    (declare (fixnum idx limit))
602    (when (= idx limit)
603      (unless (%ioblock-advance ioblock t)
604        (return-from %ioblock-read-u16-byte :eof))
605      (setq idx (io-buffer-idx buf)
606            limit (io-buffer-count buf)))
607    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
608    (aref (the (simple-array (unsigned-byte 16) (*))
609            (io-buffer-buffer buf)) idx)))
610
[5212]611(defun %private-ioblock-read-u16-byte (ioblock)
612  (declare (optimize (speed 3) (safety 0)))
613  (check-ioblock-owner ioblock)
614  (%ioblock-read-u16-byte ioblock))
615
616(defun %locked-ioblock-read-u16-byte (ioblock)
617  (declare (optimize (speed 3) (safety 0)))
618  (with-ioblock-input-lock-grabbed (ioblock)
619    (%ioblock-read-u16-byte ioblock)))
620
[5208]621(declaim (inline %ioblock-read-s16-byte))
622(defun %ioblock-read-s16-byte (ioblock)
623  (declare (optimize (speed 3) (safety 0)))
624  (let* ((buf (ioblock-inbuf ioblock))
625         (idx (io-buffer-idx buf))
626         (limit (io-buffer-count buf)))
627    (declare (fixnum idx limit))
628    (when (= idx limit)
629      (unless (%ioblock-advance ioblock t)
630        (return-from %ioblock-read-s16-byte :eof))
631      (setq idx (io-buffer-idx buf)
632            limit (io-buffer-count buf)))
633    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
634    (aref (the (simple-array (signed-byte 16) (*))
635            (io-buffer-buffer buf)) idx)))
636
[5212]637(defun %private-ioblock-read-s16-byte (ioblock)
638  (declare (optimize (speed 3) (safety 0)))
639  (check-ioblock-owner ioblock)
640  (%ioblock-read-s16-byte ioblock))
641
642(defun %locked-ioblock-read-s16-byte (ioblock)
643  (declare (optimize (speed 3) (safety 0)))
644  (with-ioblock-input-lock-grabbed (ioblock)
645    (%ioblock-read-s16-byte ioblock)))
646
647
[5208]648(declaim (inline %ioblock-read-u32-byte))
649(defun %ioblock-read-u32-byte (ioblock)
650  (declare (optimize (speed 3) (safety 0)))
651  (let* ((buf (ioblock-inbuf ioblock))
652         (idx (io-buffer-idx buf))
653         (limit (io-buffer-count buf)))
654    (declare (fixnum idx limit))
655    (when (= idx limit)
656      (unless (%ioblock-advance ioblock t)
657        (return-from %ioblock-read-u32-byte :eof))
658      (setq idx (io-buffer-idx buf)
659            limit (io-buffer-count buf)))
660    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
661    (aref (the (simple-array (unsigned-byte 32) (*))
662            (io-buffer-buffer buf)) idx)))
663
[5212]664(defun %private-ioblock-read-u32-byte (ioblock)
[5208]665  (check-ioblock-owner ioblock)
[5212]666  (%ioblock-read-u32-byte ioblock))
[5208]667
[5212]668(defun %locked-ioblock-read-u32-byte (ioblock)
669  (with-ioblock-input-lock-grabbed (ioblock)
670    (%ioblock-read-u32-byte ioblock)))
671
672(declaim (inline %ioblock-read-s32-byte))
673(defun %ioblock-read-s32-byte (ioblock)
674  (declare (optimize (speed 3) (safety 0)))
675  (let* ((buf (ioblock-inbuf ioblock))
676         (idx (io-buffer-idx buf))
677         (limit (io-buffer-count buf)))
678    (declare (fixnum idx limit))
679    (when (= idx limit)
680      (unless (%ioblock-advance ioblock t)
681        (return-from %ioblock-read-s32-byte :eof))
682      (setq idx (io-buffer-idx buf)
683            limit (io-buffer-count buf)))
684    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
685    (aref (the (simple-array (signed-byte 32) (*))
686            (io-buffer-buffer buf)) idx)))
687
688(defun %private-ioblock-read-s32-byte (ioblock)
[5208]689  (check-ioblock-owner ioblock)
[5212]690  (%ioblock-read-s32-byte ioblock))
[5208]691
[5212]692(defun %locked-ioblock-read-s32-byte (ioblock)
693  (with-ioblock-input-lock-grabbed (ioblock)
694    (%ioblock-read-s32-byte ioblock)))
[5208]695
[5212]696#+64-bit-target
697(progn
698(declaim (inline %ioblock-read-u64-byte))
699(defun %ioblock-read-u64-byte (ioblock)
700  (declare (optimize (speed 3) (safety 0)))
701  (let* ((buf (ioblock-inbuf ioblock))
702         (idx (io-buffer-idx buf))
703         (limit (io-buffer-count buf)))
704    (declare (fixnum idx limit))
705    (when (= idx limit)
706      (unless (%ioblock-advance ioblock t)
707        (return-from %ioblock-read-u64-byte :eof))
708      (setq idx (io-buffer-idx buf)
709            limit (io-buffer-count buf)))
710    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
711    (aref (the (simple-array (unsigned-byte 64) (*))
712            (io-buffer-buffer buf)) idx)))
713
714(defun %private-ioblock-read-u64-byte (ioblock)
715  (declare (optimize (speed 3) (safety 0)))
716  (check-ioblock-owner ioblock)
717  (%ioblock-read-u64-byte ioblock))
718
719(defun %locked-ioblock-read-u64-byte (ioblock)
720  (declare (optimize (speed 3) (safety 0)))
721  (with-ioblock-input-lock-grabbed (ioblock)
722    (%ioblock-read-u64-byte ioblock)))
723
724(defun %ioblock-read-s64-byte (ioblock)
725  (declare (optimize (speed 3) (safety 0)))
726  (let* ((buf (ioblock-inbuf ioblock))
727         (idx (io-buffer-idx buf))
728         (limit (io-buffer-count buf)))
729    (declare (fixnum idx limit))
730    (when (= idx limit)
731      (unless (%ioblock-advance ioblock t)
732        (return-from %ioblock-read-s64-byte :eof))
733      (setq idx (io-buffer-idx buf)
734            limit (io-buffer-count buf)))
735    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
736    (aref (the (simple-array (signed-byte 64) (*))
737            (io-buffer-buffer buf)) idx)))
738
739(defun %private-ioblock-read-s64-byte (ioblock)
740  (declare (optimize (speed 3) (safety 0)))
741  (check-ioblock-owner ioblock)
742  (%ioblock-read-s64-byte ioblock))
743
744(defun %locked-ioblock-read-s64-byte (ioblock)
745  (declare (optimize (speed 3) (safety 0)))
746  (with-ioblock-input-lock-grabbed (ioblock)
747    (%ioblock-read-s64-byte ioblock)))
748)
749
[5292]750
751;;; Read a 16-bit code element from a stream with element-type
752;;; (UNSIGNED-BYTE 8), in native byte-order.
753
[5306]754(declaim (inline %ioblock-read-u16-code-unit))
755(defun %ioblock-read-u16-code-unit (ioblock)
[5202]756  (declare (optimize (speed 3) (safety 0)))
757  (let* ((buf (ioblock-inbuf ioblock))
758         (idx (io-buffer-idx buf))
[5292]759         (limit (io-buffer-count buf))
760         (vector (io-buffer-buffer buf)))
761    (declare (fixnum idx limit)
762             (type (simple-array (unsigned-byte 8) (*)) vector))
763    (if (<= (the fixnum (+ idx 2)) limit)
764      (let* ((b0 (aref vector idx))
765             (b1 (aref vector (the fixnum (1+ idx)))))
766        (declare (type (unsigned-byte 8) b0 b1))
767        (setf (io-buffer-idx buf) (the fixnum (+ idx 2)))
768        #+big-endian-target
769        (logior (the (unsigned-byte 16) (ash b0 8)) b1)
770        #+little-endian-target
771        (logior (the (unsigned-byte 16) (ash b1 8)) b0))
772      (if (< idx limit)
773        (let* ((b0 (aref vector idx))
774               (n (%ioblock-advance ioblock t)))
775          (declare (type (unsigned-byte 8) b0))
776          (if (null n)
777            :eof
778            (let* ((b1 (aref vector 0)))
779              (declare (type (unsigned-byte 8) b1))
780              (setf (io-buffer-idx buf) 1)
781              #+big-endian-target
782              (logior (the (unsigned-byte 16) (ash b0 8)) b1)
783              #+little-endian-target
784              (logior (the (unsigned-byte 16) (ash b1 8)) b0))))
785        (let* ((n (%ioblock-advance ioblock t)))
786          (if (null n)
787            :eof
788            (if (eql n 1)
789              (progn
790                (setf (io-buffer-idx buf) 1)
791                :eof)
792              (let* ((b0 (aref vector 0))
793                     (b1 (aref vector 1)))
794                (declare (type (unsigned-byte 8) b0 b1))
795                (setf (io-buffer-idx buf) 2)
796                #+big-endian-target
797                (logior (the (unsigned-byte 16) (ash b0 8)) b1)
798                #+little-endian-target
799                (logior (the (unsigned-byte 16) (ash b1 8)) b0)))))))))
800 
[5306]801(declaim (inline %ioblock-read-swapped-u16-code-unit))
802(defun %ioblock-read-swapped-u16-code-unit (ioblock)
[5292]803  (declare (optimize (speed 3) (safety 0)))
804    (let* ((buf (ioblock-inbuf ioblock))
805         (idx (io-buffer-idx buf))
806         (limit (io-buffer-count buf))
807         (vector (io-buffer-buffer buf)))
808    (declare (fixnum idx limit)
809             (type (simple-array (unsigned-byte 8) (*)) vector))
810    (if (<= (the fixnum (+ idx 2)) limit)
811      (let* ((b0 (aref vector idx))
812             (b1 (aref vector (the fixnum (1+ idx)))))
813        (declare (type (unsigned-byte 8) b0 b1))
814        (setf (io-buffer-idx buf) (the fixnum (+ idx 2)))
815        #+little-endian-target
816        (logior (the (unsigned-byte 16) (ash b0 8)) b1)
817        #+big-endian-target
818        (logior (the (unsigned-byte 16) (ash b1 8)) b0))
819      (if (< idx limit)
820        (let* ((b0 (aref vector idx))
821               (n (%ioblock-advance ioblock t)))
822          (declare (type (unsigned-byte 8) b0))
823          (if (null n)
824            :eof
825            (let* ((b1 (aref vector 0)))
826              (declare (type (unsigned-byte 8) b1))
827              (setf (io-buffer-idx buf) 1)
828              #+little-endian-target
829              (logior (the (unsigned-byte 16) (ash b0 8)) b1)
830              #+big-endian-target
831              (logior (the (unsigned-byte 16) (ash b1 8)) b0))))
832        (let* ((n (%ioblock-advance ioblock t)))
833          (if (null n)
834            :eof
835            (if (eql n 1)
836              (progn
837                (setf (io-buffer-idx buf) 1)
838                :eof)
839              (let* ((b0 (aref vector 0))
840                     (b1 (aref vector 1)))
841                (declare (type (unsigned-byte 8) b0 b1))
842                (setf (io-buffer-idx buf) 2)
843                #+little-endian-target
844                (logior (the (unsigned-byte 16) (ash b0 8)) b1)
845                #+big-endian-target
846                (logior (the (unsigned-byte 16) (ash b1 8)) b0)))))))))
[5202]847
[5292]848
[5306]849(declaim (inline %ioblock-read-u32-code-unit))
850(defun %ioblock-read-u32-code-unit (ioblock)
[5226]851  (declare (optimize (speed 3) (safety 0)))
852  (let* ((buf (ioblock-inbuf ioblock))
853         (idx (io-buffer-idx buf))
[5292]854         (limit (io-buffer-count buf))
855         (vector (io-buffer-buffer buf)))
856    (declare (fixnum idx limit)
857             (type (simple-array (unsigned-byte 8) (*)) vector))
858    (cond ((<= (the fixnum (+ idx 4)) limit)
859           (let* ((b0 (aref vector idx))
860                  (b1 (aref vector (the fixnum (1+ idx))))
861                  (b2 (aref vector (the fixnum (+ idx 2))))
862                  (b3 (aref vector (the fixnum (+ idx 3)))))
863             (declare (type (unsigned-byte 8) b0 b1 b2 b3))
864             (setf (io-buffer-idx buf) (the fixnum (+ idx 4)))
865             #+big-endian-target
866             (logior (the (unsigned-byte 32) (ash b0 24))
867                     (the (unsigned-byte 24) (ash b1 16))
868                     (the (unsigned-byte 16) (ash b2 8))
869                     b3)
870             #+little-endian-target
871             (logior (the (unsigned-byte 32) (ash b3 24))
872                     (the (unsigned-byte 24) (ash b2 16))
873                     (the (unsigned-byte 16) (ash b1 8))
874                     b0)))
875          ((= (the fixnum (+ idx 3)) limit)
876           (let* ((b0 (aref vector idx))
877                  (b1 (aref vector (the fixnum (1+ idx))))
878                  (b2 (aref vector (the fixnum (+ idx 2))))
879                  (n (%ioblock-advance ioblock t)))
880             (declare (type (unsigned-byte 8) b0 b1 b2))
881             (if (null n)
882               :eof
883               (let* ((b3 (aref vector 0)))
884                 (declare (type (unsigned-byte 8) b3))
885                 (setf (io-buffer-idx buf) 1)
886                 #+big-endian-target
887                 (logior (the (unsigned-byte 32) (ash b0 24))
888                         (the (unsigned-byte 24) (ash b1 16))
889                         (the (unsigned-byte 16) (ash b2 8))
890                         b3)
891                 #+little-endian-target
892                 (logior (the (unsigned-byte 32) (ash b3 24))
893                         (the (unsigned-byte 24) (ash b2 16))
894                         (the (unsigned-byte 16) (ash b1 8))
895                         b0)))))
896          ((= (the fixnum (+ idx 2)) limit)
897           (let* ((b0 (aref vector idx))
898                  (b1 (aref vector (the fixnum (1+ idx))))
899                  (n (%ioblock-advance ioblock t)))
900             (declare (type (unsigned-byte 8) b0 b1))
901             (if (null n)
902               :eof
903               (if (eql n 1)
904                 (progn
905                   (setf (io-buffer-idx buf) 1)
906                   :eof)
907                 (let* ((b2 (aref vector 0))
908                        (b3 (aref vector 1)))
909                   (declare (type (unsigned-byte 8) b2 b3))
910                   (setf (io-buffer-idx buf) 2)
911                   #+big-endian-target
912                   (logior (the (unsigned-byte 32) (ash b0 24))
913                           (the (unsigned-byte 24) (ash b1 16))
914                           (the (unsigned-byte 16) (ash b2 8))
915                           b3)
916                   #+little-endian-target
917                   (logior (the (unsigned-byte 32) (ash b3 24))
918                           (the (unsigned-byte 24) (ash b2 16))
919                           (the (unsigned-byte 16) (ash b1 8))
920                           b0))))))
921          ((= (the fixnum (1+ idx)) limit)
922           (let* ((b0 (aref vector idx))
923                  (n (%ioblock-advance ioblock t)))
924             (declare (type (unsigned-byte 8) b0))
925             (if (null n)
926               :eof
927               (if (< n 3)
928                 (progn
929                   (setf (io-buffer-idx buf) n)
930                   :eof)
931                 (let* ((b1 (aref vector 0))
932                        (b2 (aref vector 1))
933                        (b3 (aref vector 2)))
934                   (setf (io-buffer-idx buf) 3)
935                   #+big-endian-target
936                   (logior (the (unsigned-byte 32) (ash b0 24))
937                           (the (unsigned-byte 24) (ash b1 16))
938                           (the (unsigned-byte 16) (ash b2 8))
939                           b3)
940                   #+little-endian-target
941                   (logior (the (unsigned-byte 32) (ash b3 24))
942                           (the (unsigned-byte 24) (ash b2 16))
943                           (the (unsigned-byte 16) (ash b1 8))
944                           b0))))))
945          (t
946           (let* ((n (%ioblock-advance ioblock t)))
947             (if (null n)
948               :eof
949               (if (< n 4)
950                 (progn
951                   (setf (io-buffer-idx buf) n)
952                   :eof)
953                 (let* ((b0 (aref vector 0))
954                        (b1 (aref vector 1))
955                        (b2 (aref vector 2))
956                        (b3 (aref vector 3)))
957                (declare (type (unsigned-byte 8) b0 b1 b2 b3))
958                (setf (io-buffer-idx buf) 4)
959                #+big-endian-target
960                (logior (the (unsigned-byte 32) (ash b0 24))
961                        (the (unsigned-byte 24) (ash b1 16))
962                        (the (unsigned-byte 16) (ash b2 8))
963                        b3)
964                #+little-endian-target
965                (logior (the (unsigned-byte 32) (ash b3 24))
966                        (the (unsigned-byte 24) (ash b2 16))
967                        (the (unsigned-byte 16) (ash b1 8))
968                        b0)))))))))
[5202]969
[5306]970(declaim (inline %ioblock-read-swapped-u32-code-unit))
971(defun %ioblock-read-swapped-u32-code-unit (ioblock)
[5292]972  (declare (optimize (speed 3) (safety 0)))
973  (let* ((buf (ioblock-inbuf ioblock))
974         (idx (io-buffer-idx buf))
975         (limit (io-buffer-count buf))
976         (vector (io-buffer-buffer buf)))
977    (declare (fixnum idx limit)
978             (type (simple-array (unsigned-byte 8) (*)) vector))
979    (cond ((<= (the fixnum (+ idx 4)) limit)
980           (let* ((b0 (aref vector idx))
981                  (b1 (aref vector (the fixnum (1+ idx))))
982                  (b2 (aref vector (the fixnum (+ idx 2))))
983                  (b3 (aref vector (the fixnum (+ idx 3)))))
984             (declare (type (unsigned-byte 8) b0 b1 b2 b3))
985             (setf (io-buffer-idx buf) (the fixnum (+ idx 4)))
986             #+little-endian-target
987             (logior (the (unsigned-byte 32) (ash b0 24))
988                     (the (unsigned-byte 24) (ash b1 16))
989                     (the (unsigned-byte 16) (ash b2 8))
990                     b3)
991             #+big-endian-target
992             (logior (the (unsigned-byte 32) (ash b3 24))
993                     (the (unsigned-byte 24) (ash b2 16))
994                     (the (unsigned-byte 16) (ash b1 8))
995                     b0)))
996          ((= (the fixnum (+ idx 3)) limit)
997           (let* ((b0 (aref vector idx))
998                  (b1 (aref vector (the fixnum (1+ idx))))
999                  (b2 (aref vector (the fixnum (+ idx 2))))
1000                  (n (%ioblock-advance ioblock t)))
1001             (declare (type (unsigned-byte 8) b0 b1 b2))
1002             (if (null n)
1003               :eof
1004               (let* ((b3 (aref vector 0)))
1005                 (declare (type (unsigned-byte 8) b3))
1006                 (setf (io-buffer-idx buf) 1)
1007                 #+little-endian-target
1008                 (logior (the (unsigned-byte 32) (ash b0 24))
1009                         (the (unsigned-byte 24) (ash b1 16))
1010                         (the (unsigned-byte 16) (ash b2 8))
1011                         b3)
1012                 #+big-endian-target
1013                 (logior (the (unsigned-byte 32) (ash b3 24))
1014                         (the (unsigned-byte 24) (ash b2 16))
1015                         (the (unsigned-byte 16) (ash b1 8))
1016                         b0)))))
1017          ((= (the fixnum (+ idx 2)) limit)
1018           (let* ((b0 (aref vector idx))
1019                  (b1 (aref vector (the fixnum (1+ idx))))
1020                  (n (%ioblock-advance ioblock t)))
1021             (declare (type (unsigned-byte 8) b0 b1))
1022             (if (null n)
1023               :eof
1024               (if (eql n 1)
1025                 (progn
1026                   (setf (io-buffer-idx buf) 1)
1027                   :eof)
1028                 (let* ((b2 (aref vector 0))
1029                        (b3 (aref vector 1)))
1030                   (declare (type (unsigned-byte 8) b2 b3))
1031                   (setf (io-buffer-idx buf) 2)
1032                   #+little-endian-target
1033                   (logior (the (unsigned-byte 32) (ash b0 24))
1034                           (the (unsigned-byte 24) (ash b1 16))
1035                           (the (unsigned-byte 16) (ash b2 8))
1036                           b3)
1037                   #+big-endian-target
1038                   (logior (the (unsigned-byte 32) (ash b3 24))
1039                           (the (unsigned-byte 24) (ash b2 16))
1040                           (the (unsigned-byte 16) (ash b1 8))
1041                           b0))))))
1042          ((= (the fixnum (1+ idx)) limit)
1043           (let* ((b0 (aref vector idx))
1044                  (n (%ioblock-advance ioblock t)))
1045             (declare (type (unsigned-byte 8) b0))
1046             (if (null n)
1047               :eof
1048               (if (< n 3)
1049                 (progn
1050                   (setf (io-buffer-idx buf) n)
1051                   :eof)
1052                 (let* ((b1 (aref vector 0))
1053                        (b2 (aref vector 1))
1054                        (b3 (aref vector 2)))
1055                   (setf (io-buffer-idx buf) 3)
1056                   #+little-endian-target
1057                   (logior (the (unsigned-byte 32) (ash b0 24))
1058                           (the (unsigned-byte 24) (ash b1 16))
1059                           (the (unsigned-byte 16) (ash b2 8))
1060                           b3)
1061                   #+big-endian-target
1062                   (logior (the (unsigned-byte 32) (ash b3 24))
1063                           (the (unsigned-byte 24) (ash b2 16))
1064                           (the (unsigned-byte 16) (ash b1 8))
1065                           b0))))))
1066          (t
1067           (let* ((n (%ioblock-advance ioblock t)))
1068             (if (null n)
1069               :eof
1070               (if (< n 4)
1071                 (progn
1072                   (setf (io-buffer-idx buf) n)
1073                   :eof)
1074                 (let* ((b0 (aref vector 0))
1075                        (b1 (aref vector 1))
1076                        (b2 (aref vector 2))
1077                        (b3 (aref vector 3)))
1078                (declare (type (unsigned-byte 8) b0 b1 b2 b3))
1079                (setf (io-buffer-idx buf) 4)
1080                #+little-endian-target
1081                (logior (the (unsigned-byte 32) (ash b0 24))
1082                        (the (unsigned-byte 24) (ash b1 16))
1083                        (the (unsigned-byte 16) (ash b2 8))
1084                        b3)
1085                #+big-endian-target
1086                (logior (the (unsigned-byte 32) (ash b3 24))
1087                        (the (unsigned-byte 24) (ash b2 16))
1088                        (the (unsigned-byte 16) (ash b1 8))
1089                        b0)))))))))
[5226]1090
[5292]1091
[4918]1092(defun %bivalent-private-ioblock-read-u8-byte (ioblock)
1093  (declare (optimize (speed 3) (safety 0)))
1094  (check-ioblock-owner ioblock)
[5427]1095  (setf (ioblock-untyi-char ioblock) nil)
[4901]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)
[4918]1102          (return-from %bivalent-private-ioblock-read-u8-byte :eof))
[4901]1103        (setq idx (io-buffer-idx buf)
1104              limit (io-buffer-count buf)))
1105      (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
[4918]1106      (aref (the (simple-array (unsigned-byte 8) (*))
[5427]1107              (io-buffer-buffer buf)) idx)))
[4901]1108
[4918]1109(defun %private-ioblock-read-u8-byte (ioblock)
1110  (declare (optimize (speed 3) (safety 0)))
1111  (check-ioblock-owner ioblock)
[5212]1112  (%ioblock-read-u8-byte ioblock))
[4901]1113
[4918]1114(defun %bivalent-locked-ioblock-read-u8-byte (ioblock)
1115  (declare (optimize (speed 3) (safety 0)))
[5226]1116  (with-ioblock-input-lock-grabbed (ioblock)
[5427]1117    (setf (ioblock-untyi-char ioblock) nil)
1118    (let* ((buf (ioblock-inbuf ioblock))
1119           (idx (io-buffer-idx buf))
1120           (limit (io-buffer-count buf)))
1121      (declare (fixnum idx limit))
1122      (when (= idx limit)
1123        (unless (%ioblock-advance ioblock t)
1124          (return-from %bivalent-locked-ioblock-read-u8-byte :eof))
1125        (setq idx (io-buffer-idx buf)
1126              limit (io-buffer-count buf)))
1127      (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
1128      (aref (the (simple-array (unsigned-byte 8) (*))
1129              (io-buffer-buffer buf)) idx))))
[4901]1130
[4918]1131(defun %locked-ioblock-read-u8-byte (ioblock)
1132  (declare (optimize (speed 3) (safety 0)))
[5212]1133  (with-ioblock-input-lock-grabbed (ioblock)
1134    (%ioblock-read-u8-byte ioblock)))
[4885]1135
[4918]1136(defun %general-ioblock-read-byte (ioblock)
[4885]1137  (declare (optimize (speed 3) (safety 0)))
[4918]1138  (with-ioblock-input-locked (ioblock)
[6]1139    (let* ((buf (ioblock-inbuf ioblock))
[4918]1140           (idx (io-buffer-idx buf))
1141           (limit (io-buffer-count buf)))
[6]1142      (declare (fixnum idx limit))
1143      (when (= idx limit)
[4918]1144        (unless (%ioblock-advance ioblock t)
1145          (return-from %general-ioblock-read-byte :eof))
1146        (setq idx (io-buffer-idx buf)
1147              limit (io-buffer-count buf)))
[4885]1148      (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
[4918]1149      (uvref (io-buffer-buffer buf) idx))))
[6]1150
[4918]1151
[5192]1152(declaim (inline %ioblock-tyi))
[4918]1153(defun %ioblock-tyi (ioblock)
1154  (declare (optimize (speed 3) (safety 0)))
1155  (let* ((ch (ioblock-untyi-char ioblock)))
1156    (if ch
1157      (prog1 ch
1158        (setf (ioblock-untyi-char ioblock) nil))
[5264]1159      (let* ((buf (ioblock-inbuf ioblock))
1160             (idx (io-buffer-idx buf))
1161             (limit (io-buffer-count buf)))
1162        (declare (fixnum idx limit))
1163        (when (= idx limit)
1164          (unless (%ioblock-advance ioblock t)
1165            (return-from %ioblock-tyi :eof))
[5319]1166          (setq idx 0))
[5264]1167        (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
1168        (%code-char (aref (the (simple-array (unsigned-byte 8) (*))
[5319]1169                                       (io-buffer-buffer buf)) idx))))))
[4918]1170
[4895]1171(defun %private-ioblock-tyi (ioblock)
1172  (declare (optimize (speed 3) (safety 0)))
1173  (check-ioblock-owner ioblock)
[5192]1174  (%ioblock-tyi ioblock))
[4895]1175
1176(defun %locked-ioblock-tyi (ioblock)
1177  (declare (optimize (speed 3) (safety 0)))
[5212]1178  (with-ioblock-input-lock-grabbed (ioblock)
[5192]1179    (%ioblock-tyi ioblock)))
1180
1181;;; Read a character composed of one or more 8-bit code-units.
1182(declaim (inline %ioblock-read-u8-encoded-char))
1183(defun %ioblock-read-u8-encoded-char (ioblock)
1184  (declare (optimize (speed 3) (safety 0)))
1185  (let* ((ch (ioblock-untyi-char ioblock)))
1186    (if ch
1187      (prog1 ch
[4895]1188        (setf (ioblock-untyi-char ioblock) nil))
[5319]1189      (let* ((1st-unit (%ioblock-read-u8-code-unit ioblock)))
[5192]1190        (if (eq 1st-unit :eof)
1191          1st-unit
1192          (locally
1193              (declare (type (unsigned-byte 8) 1st-unit))
1194            (if (< 1st-unit
[6538]1195                   (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock)))
[5192]1196              (%code-char 1st-unit)
1197              (funcall (ioblock-decode-input-function ioblock)
1198                       1st-unit
[5319]1199                       #'%ioblock-read-u8-code-unit
[5192]1200                       ioblock))))))))
[4895]1201
[5202]1202(defun %private-ioblock-read-u8-encoded-char (ioblock)
1203  (declare (optimize (speed 3) (safety 0)))
1204  (check-ioblock-owner ioblock)
1205  (%ioblock-read-u8-encoded-char ioblock))
1206
[5245]1207(defun %locked-ioblock-read-u8-encoded-char (ioblock)
[5202]1208  (declare (optimize (speed 3) (safety 0)))
[5392]1209  (with-ioblock-input-lock-grabbed (ioblock)
[5202]1210    (%ioblock-read-u8-encoded-char ioblock)))
1211
1212(declaim (inline %ioblock-read-u16-encoded-char))
1213(defun %ioblock-read-u16-encoded-char (ioblock)
1214  (declare (optimize (speed 3) (safety 0)))
1215  (let* ((ch (ioblock-untyi-char ioblock)))
1216    (if ch
1217      (prog1 ch
1218        (setf (ioblock-untyi-char ioblock) nil))
[5306]1219      (let* ((1st-unit (%ioblock-read-u16-code-unit ioblock)))
[5202]1220        (if (eq 1st-unit :eof)
1221          1st-unit
1222          (locally
1223              (declare (type (unsigned-byte 16) 1st-unit))
1224            (if (< 1st-unit
[6538]1225                   (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock)))
[5202]1226              (code-char 1st-unit)
1227              (funcall (ioblock-decode-input-function ioblock)
1228                       1st-unit
[5306]1229                       #'%ioblock-read-u16-code-unit
[5202]1230                       ioblock))))))))
1231
1232(defun %private-ioblock-read-u16-encoded-char (ioblock)
1233  (declare (optimize (speed 3) (safety 0)))
1234  (check-ioblock-owner ioblock)
1235  (%ioblock-read-u16-encoded-char ioblock))
1236
1237(defun %locked-ioblock-read-u16-encoded-char (ioblock)
1238  (declare (optimize (speed 3) (safety 0)))
[5212]1239  (with-ioblock-input-lock-grabbed (ioblock)
[5202]1240    (%ioblock-read-u16-encoded-char ioblock)))
1241
[5256]1242(declaim (inline %ioblock-read-swapped-u16-encoded-char))
1243(defun %ioblock-read-swapped-u16-encoded-char (ioblock)
1244  (declare (optimize (speed 3) (safety 0)))
1245  (let* ((ch (ioblock-untyi-char ioblock)))
1246    (if ch
1247      (prog1 ch
1248        (setf (ioblock-untyi-char ioblock) nil))
[5306]1249      (let* ((1st-unit (%ioblock-read-swapped-u16-code-unit ioblock)))
[5256]1250        (if (eq 1st-unit :eof)
1251          1st-unit
1252          (locally
1253              (declare (type (unsigned-byte 16) 1st-unit))
1254            (if (< 1st-unit
[6538]1255                   (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock)))
[5256]1256              (code-char 1st-unit)
1257              (funcall (ioblock-decode-input-function ioblock)
1258                       1st-unit
[5306]1259                       #'%ioblock-read-swapped-u16-code-unit
[5256]1260                       ioblock))))))))
[5202]1261
[5256]1262(defun %private-ioblock-read-swapped-u16-encoded-char (ioblock)
1263  (declare (optimize (speed 3) (safety 0)))
1264  (check-ioblock-owner ioblock)
1265  (%ioblock-read-swapped-u16-encoded-char ioblock))
1266
1267(defun %locked-ioblock-read-swapped-u16-encoded-char (ioblock)
1268  (declare (optimize (speed 3) (safety 0)))
1269  (with-ioblock-input-lock-grabbed (ioblock)
1270    (%ioblock-read-swapped-u16-encoded-char ioblock)))
1271
[5354]1272(declaim (inline %ioblock-read-u32-encoded-char))
1273(defun %ioblock-read-u32-encoded-char (ioblock)
1274  (declare (optimize (speed 3) (safety 0)))
1275  (let* ((ch (ioblock-untyi-char ioblock)))
1276    (if ch
1277      (prog1 ch
1278        (setf (ioblock-untyi-char ioblock) nil))
1279      (let* ((1st-unit (%ioblock-read-u32-code-unit ioblock)))
1280        (if (eq 1st-unit :eof)
1281          1st-unit
1282          (locally
1283              (declare (type (unsigned-byte 16) 1st-unit))
1284            (if (< 1st-unit
[6538]1285                   (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock)))
[5354]1286              (code-char 1st-unit)
1287              (funcall (ioblock-decode-input-function ioblock)
1288                       1st-unit
1289                       #'%ioblock-read-u32-code-unit
1290                       ioblock))))))))
1291
1292(defun %private-ioblock-read-u32-encoded-char (ioblock)
1293  (declare (optimize (speed 3) (safety 0)))
1294  (check-ioblock-owner ioblock)
1295  (%ioblock-read-u32-encoded-char ioblock))
1296
1297(defun %locked-ioblock-read-u32-encoded-char (ioblock)
1298  (declare (optimize (speed 3) (safety 0)))
1299  (with-ioblock-input-lock-grabbed (ioblock)
1300    (%ioblock-read-u32-encoded-char ioblock)))
1301
1302(declaim (inline %ioblock-read-swapped-u32-encoded-char))
1303(defun %ioblock-read-swapped-u32-encoded-char (ioblock)
1304  (declare (optimize (speed 3) (safety 0)))
1305  (let* ((ch (ioblock-untyi-char ioblock)))
1306    (if ch
1307      (prog1 ch
1308        (setf (ioblock-untyi-char ioblock) nil))
1309      (let* ((1st-unit (%ioblock-read-swapped-u32-code-unit ioblock)))
1310        (if (eq 1st-unit :eof)
1311          1st-unit
1312          (locally
1313              (declare (type (unsigned-byte 16) 1st-unit))
1314            (if (< 1st-unit
[6538]1315                   (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock)))
[5354]1316              (code-char 1st-unit)
1317              (funcall (ioblock-decode-input-function ioblock)
1318                       1st-unit
1319                       #'%ioblock-read-swapped-u32-code-unit
1320                       ioblock))))))))
1321
1322(defun %private-ioblock-read-swapped-u32-encoded-char (ioblock)
1323  (declare (optimize (speed 3) (safety 0)))
1324  (check-ioblock-owner ioblock)
1325  (%ioblock-read-swapped-u32-encoded-char ioblock))
1326
1327(defun %locked-ioblock-read-swapped-u32-encoded-char (ioblock)
1328  (declare (optimize (speed 3) (safety 0)))
1329  (with-ioblock-input-lock-grabbed (ioblock)
1330    (%ioblock-read-swapped-u32-encoded-char ioblock)))
1331
[5192]1332(declaim (inline %ioblock-tyi-no-hang))
[4885]1333(defun %ioblock-tyi-no-hang (ioblock)
1334  (declare (optimize (speed 3) (safety 0)))
1335  (if (ioblock-untyi-char ioblock)
1336    (prog1 (ioblock-untyi-char ioblock)
1337      (setf (ioblock-untyi-char ioblock) nil))
1338    (let* ((buf (ioblock-inbuf ioblock))
1339           (idx (io-buffer-idx buf))
1340           (limit (io-buffer-count buf)))
1341      (declare (fixnum idx limit))
1342      (when (= idx limit)
1343        (unless (%ioblock-advance ioblock nil)
[5245]1344          (return-from %ioblock-tyi-no-hang (if (ioblock-eof ioblock) :eof))))
1345      (funcall (ioblock-read-char-when-locked-function ioblock) ioblock))))
[4885]1346
[5245]1347;;; :iso-8859-1 only.
[6]1348(defun %ioblock-peek-char (ioblock)
1349  (or (ioblock-untyi-char ioblock)
1350      (let* ((buf (ioblock-inbuf ioblock))
1351             (idx (io-buffer-idx buf))
1352             (limit (io-buffer-count buf)))
1353        (declare (fixnum idx limit))
1354        (when (= idx limit)
1355          (unless (%ioblock-advance ioblock t)
1356            (return-from %ioblock-peek-char :eof))
1357          (setq idx (io-buffer-idx buf)
1358                limit (io-buffer-count buf)))
[5051]1359        (%code-char (aref (the (simple-array (unsigned-byte 8) (*)) (io-buffer-buffer buf)) idx)))))
[6]1360
[5245]1361(defun %encoded-ioblock-peek-char (ioblock)
1362  (or (ioblock-untyi-char ioblock)
[5427]1363      (let* ((ch (funcall (ioblock-read-char-when-locked-function ioblock) ioblock)))
[5245]1364        (unless (eq ch :eof)
1365          (setf (ioblock-untyi-char ioblock) ch))
1366        ch)))
1367
1368
1369
1370
[6]1371(defun %ioblock-clear-input (ioblock)   
1372    (let* ((buf (ioblock-inbuf ioblock)))
1373      (setf (io-buffer-count buf) 0
1374            (io-buffer-idx buf) 0
1375            (ioblock-untyi-char ioblock) nil)))
1376
1377(defun %ioblock-untyi (ioblock char)
1378  (if (ioblock-untyi-char ioblock)
1379    (error "Two UNREAD-CHARs without intervening READ-CHAR on ~s"
1380           (ioblock-stream ioblock))
1381    (setf (ioblock-untyi-char ioblock) char)))
1382
1383(declaim (inline ioblock-inpos))
1384
1385(defun ioblock-inpos (ioblock)
1386  (io-buffer-idx (ioblock-inbuf ioblock)))
1387
1388(declaim (inline ioblock-outpos))
1389
1390(defun ioblock-outpos (ioblock)
1391  (io-buffer-count (ioblock-outbuf ioblock)))
1392
[5245]1393
1394
[6]1395(declaim (inline %ioblock-force-output))
1396
1397(defun %ioblock-force-output (ioblock finish-p)
1398  (funcall (ioblock-force-output-function ioblock)
1399           (ioblock-stream ioblock)
1400           ioblock
1401           (ioblock-outpos ioblock)
1402           finish-p))
1403
1404;;; ivector should be an ivector.  The ioblock should have an
1405;;; element-shift of 0; start-octet and num-octets should of course
1406;;; be sane.  This is mostly to give the fasdumper a quick way to
1407;;; write immediate data.
1408(defun %ioblock-out-ivect (ioblock ivector start-octet num-octets)
1409  (unless (= 0 (the fixnum (ioblock-element-shift ioblock)))
1410    (error "Can't write vector to stream ~s" (ioblock-stream ioblock)))
1411  (let* ((written 0)
1412         (out (ioblock-outbuf ioblock))
1413         (bufsize (io-buffer-size out))
1414         (buffer (io-buffer-buffer out)))
1415    (declare (fixnum written bufsize))
1416    (do* ((pos start-octet (+ pos written))
1417          (left num-octets (- left written)))
1418         ((= left 0) num-octets)
1419      (declare (fixnum pos left))
1420      (setf (ioblock-dirty ioblock) t)
1421      (let* ((index (io-buffer-idx out))
1422             (count (io-buffer-count out))
1423             (avail (- bufsize index)))
1424        (declare (fixnum index avail count))
1425        (cond
1426          ((= (setq written avail) 0)
1427           (%ioblock-force-output ioblock nil))
1428          (t
1429           (if (> written left)
1430             (setq written left))
1431           (%copy-ivector-to-ivector ivector pos buffer index written)
1432           (setf (ioblock-dirty ioblock) t)
1433           (incf index written)
1434           (if (> index count)
1435             (setf (io-buffer-count out) index))
1436           (setf (io-buffer-idx out) index)
1437           (if (= index  bufsize)
1438             (%ioblock-force-output ioblock nil))))))))
1439
1440
[5202]1441(defun %ioblock-unencoded-write-simple-string (ioblock string start-char num-chars)
[5335]1442  (declare (fixnum start-char num-chars) (simple-string string))
[6]1443  (let* ((written 0)
1444         (col (ioblock-charpos ioblock))
1445         (out (ioblock-outbuf ioblock))
1446         (bufsize (io-buffer-size out))
1447         (buffer (io-buffer-buffer out)))
1448    (declare (fixnum written bufsize col)
[5051]1449             (type (simple-array (unsigned-byte 8) (*)) buffer)
[6]1450             (optimize (speed 3) (safety 0)))
[5202]1451    (do* ((pos start-char (+ pos written))
1452          (left num-chars (- left written)))
1453         ((= left 0) (setf (ioblock-charpos ioblock) col)  num-chars)
[6]1454      (declare (fixnum pos left))
1455      (setf (ioblock-dirty ioblock) t)
1456      (let* ((index (io-buffer-idx out))
1457             (count (io-buffer-count out))
1458             (avail (- bufsize index)))
1459        (declare (fixnum index avail count))
1460        (cond
1461          ((= (setq written avail) 0)
1462           (%ioblock-force-output ioblock nil))
1463          (t
1464           (if (> written left)
1465             (setq written left))
1466           (do* ((p pos (1+ p))
1467                 (i index (1+ i))
1468                 (j 0 (1+ j)))
1469                ((= j written))
1470             (declare (fixnum p i j))
[5335]1471             (let* ((ch (schar string p))
1472                    (code (char-code ch)))
1473               (declare (type (mod #x110000) code))
[6]1474               (if (eql ch #\newline)
1475                 (setq col 0)
1476                 (incf col))
[5335]1477               (setf (aref buffer i) (if (>= code 256) (char-code #\Sub) code))))
[6]1478           (setf (ioblock-dirty ioblock) t)
1479           (incf index written)
1480           (if (> index count)
1481             (setf (io-buffer-count out) index))
1482           (setf (io-buffer-idx out) index)
1483           (if (= index  bufsize)
1484             (%ioblock-force-output ioblock nil))))))))
1485
1486
[5202]1487
[6]1488(defun %ioblock-eofp (ioblock)
1489  (let* ((buf (ioblock-inbuf ioblock)))
1490   (and (eql (io-buffer-idx buf)
1491             (io-buffer-count buf))
1492         (locally (declare (optimize (speed 3) (safety 0)))
1493           (with-ioblock-input-locked (ioblock)
1494             (funcall (ioblock-eofp-function ioblock)
1495                      (ioblock-stream ioblock)
1496                      ioblock))))))
1497
1498(defun %ioblock-listen (ioblock)
1499  (let* ((buf (ioblock-inbuf ioblock)))
1500    (or (< (the fixnum (io-buffer-idx buf))
1501           (the fixnum (io-buffer-count buf)))
1502        (funcall (ioblock-listen-function ioblock)
1503                 (ioblock-stream ioblock)
1504                 ioblock))))
1505
1506(declaim (inline %ioblock-write-element))
1507
1508(defun %ioblock-write-element (ioblock element)
1509  (declare (optimize (speed 3) (safety 0)))
1510  (let* ((buf (ioblock-outbuf ioblock))
1511         (idx (io-buffer-idx buf))
1512         (count (io-buffer-count buf))
1513         (limit (io-buffer-limit buf)))
1514    (declare (fixnum idx limit count))
1515    (when (= idx limit)
1516      (%ioblock-force-output ioblock nil)
1517      (setq idx 0 count 0))
1518    (setf (aref (io-buffer-buffer buf) idx) element)
1519    (incf idx)
1520    (setf (io-buffer-idx buf) idx)
1521    (when (> idx count)
1522      (setf (io-buffer-count buf) idx))
1523    (setf (ioblock-dirty ioblock) t)
1524    element))
1525
[5192]1526(declaim (inline %ioblock-write-u8-element))
1527(defun %ioblock-write-u8-element (ioblock element)
1528  (declare (optimize (speed 3) (safety 0)))
1529  (let* ((buf (ioblock-outbuf ioblock))
1530         (idx (io-buffer-idx buf))
1531         (count (io-buffer-count buf))
1532         (limit (io-buffer-limit buf)))
1533    (declare (fixnum idx limit count))
1534    (when (= idx limit)
1535      (%ioblock-force-output ioblock nil)
1536      (setq idx 0 count 0))
1537    (setf (aref (the (simple-array (unsigned-byte 8) (*)) (io-buffer-buffer buf)) idx) element)
1538    (incf idx)
1539    (setf (io-buffer-idx buf) idx)
1540    (when (> idx count)
1541      (setf (io-buffer-count buf) idx))
1542    (setf (ioblock-dirty ioblock) t)
1543    element))
1544
[5212]1545(declaim (inline %ioblock-write-s8-element))
1546(defun %ioblock-write-s8-element (ioblock element)
1547  (declare (optimize (speed 3) (safety 0)))
1548  (let* ((buf (ioblock-outbuf ioblock))
1549         (idx (io-buffer-idx buf))
1550         (count (io-buffer-count buf))
1551         (limit (io-buffer-limit buf)))
1552    (declare (fixnum idx limit count))
1553    (when (= idx limit)
1554      (%ioblock-force-output ioblock nil)
1555      (setq idx 0 count 0))
1556    (setf (aref (the (simple-array (signed-byte 8) (*)) (io-buffer-buffer buf)) idx) element)
1557    (incf idx)
1558    (setf (io-buffer-idx buf) idx)
1559    (when (> idx count)
1560      (setf (io-buffer-count buf) idx))
1561    (setf (ioblock-dirty ioblock) t)
1562    element))
1563
[5208]1564(declaim (inline %ioblock-write-u16-element))
1565(defun %ioblock-write-u16-element (ioblock element)
1566  (declare (optimize (speed 3) (safety 0)))
1567  (let* ((buf (ioblock-outbuf ioblock))
1568         (idx (io-buffer-idx buf))
1569         (count (io-buffer-count buf))
1570         (limit (io-buffer-limit buf)))
1571    (declare (fixnum idx limit count))
1572    (when (= idx limit)
1573      (%ioblock-force-output ioblock nil)
1574      (setq idx 0 count 0))
[5212]1575    (setf (aref (the (simple-array (unsigned-byte 16) (*)) (io-buffer-buffer buf)) idx) element)
[5208]1576    (incf idx)
1577    (setf (io-buffer-idx buf) idx)
1578    (when (> idx count)
1579      (setf (io-buffer-count buf) idx))
1580    (setf (ioblock-dirty ioblock) t)
1581    element))
[5192]1582
[5306]1583(declaim (inline %ioblock-write-u16-code-unit))
1584(defun %ioblock-write-u16-code-unit (ioblock element)
[5292]1585  (declare (optimize (speed 3) (safety 0))
1586           (type (unsigned-byte 16) element))
[5212]1587  (let* ((buf (ioblock-outbuf ioblock))
1588         (idx (io-buffer-idx buf))
1589         (count (io-buffer-count buf))
[5292]1590         (limit (io-buffer-limit buf))
1591         (vector (io-buffer-buffer buf))
1592         (b0 #+big-endian-target (ldb (byte 8 8) element)
1593             #+little-endian-target (ldb (byte 8 0) element))
1594         (b1 #+big-endian-target (ldb (byte 8 0) element)
1595             #+little-endian-target (ldb (byte 8 8) element)))
1596    (declare (fixnum idx limit count)
1597             (type (simple-array (unsigned-byte 8) (*)) vector)
1598             (type (unsigned-byte 8) b0 b1))
1599   
[5212]1600    (when (= idx limit)
1601      (%ioblock-force-output ioblock nil)
1602      (setq idx 0 count 0))
[5292]1603    (setf (aref vector idx) b0)
[5212]1604    (incf idx)
[5292]1605    (when (= idx limit)
[5354]1606      (when (> idx count)
1607        (setf (io-buffer-count buf) idx))
[5292]1608      (%ioblock-force-output ioblock nil)
1609      (setq idx 0 count 0))
1610    (setf (aref vector idx) b1)
1611    (incf idx)
[5212]1612    (setf (io-buffer-idx buf) idx)
1613    (when (> idx count)
1614      (setf (io-buffer-count buf) idx))
1615    (setf (ioblock-dirty ioblock) t)
1616    element))
[5208]1617
[5306]1618(declaim (inline %ioblock-write-swapped-u16-code-unit))
1619(defun %ioblock-write-swapped-u16-code-unit (ioblock element)
[5292]1620  (declare (optimize (speed 3) (safety 0)))
1621(let* ((buf (ioblock-outbuf ioblock))
1622         (idx (io-buffer-idx buf))
1623         (count (io-buffer-count buf))
1624         (limit (io-buffer-limit buf))
1625         (vector (io-buffer-buffer buf))
1626         (b0 #+big-endian-target (ldb (byte 8 8) element)
1627             #+little-endian-target (ldb (byte 8 0) element))
1628         (b1 #+big-endian-target (ldb (byte 8 0) element)
1629             #+little-endian-target (ldb (byte 8 8) element)))
1630    (declare (fixnum idx limit count)
1631             (type (simple-array (unsigned-byte 8) (*)) vector)
1632             (type (unsigned-byte 8) b0 b1))
1633   
1634    (when (= idx limit)
1635      (%ioblock-force-output ioblock nil)
1636      (setq idx 0 count 0))
1637    (setf (aref vector idx) b1)
1638    (incf idx)
1639    (when (= idx limit)
[5354]1640      (when (> idx count)
1641        (setf (io-buffer-count buf) idx))
[5292]1642      (%ioblock-force-output ioblock nil)
1643      (setq idx 0 count 0))
1644    (setf (aref vector idx) b0)
1645    (incf idx)
1646    (setf (io-buffer-idx buf) idx)
1647    (when (> idx count)
1648      (setf (io-buffer-count buf) idx))
1649    (setf (ioblock-dirty ioblock) t)
1650    element))
1651
[5354]1652(declaim (inline %ioblock-write-u32-code-unit))
1653(defun %ioblock-write-u32-code-unit (ioblock element)
1654  (declare (optimize (speed 3) (safety 0))
1655           (type (unsigned-byte 16) element))
1656  (let* ((buf (ioblock-outbuf ioblock))
1657         (idx (io-buffer-idx buf))
1658         (count (io-buffer-count buf))
1659         (limit (io-buffer-limit buf))
1660         (vector (io-buffer-buffer buf))
1661         (b0 #+big-endian-target (ldb (byte 8 24) element)
1662             #+little-endian-target (ldb (byte 8 0) element))
1663         (b1 #+big-endian-target (ldb (byte 8 16) element)
1664             #+little-endian-target (ldb (byte 8 8) element))
1665         (b2 #+big-endian-target (ldb (byte 8 8) element)
1666             #+little-endian-target (ldb (byte 8 16) element))
1667         (b3 #+big-endian-target (ldb (byte 8 0) element)
1668             #+little-endian-target (ldb (byte 8 24) element)))
1669    (declare (fixnum idx limit count)
1670             (type (simple-array (unsigned-byte 8) (*)) vector)
1671             (type (unsigned-byte 8) b0 b1 b2 b3))
1672    (when (= idx limit)
1673      (%ioblock-force-output ioblock nil)
1674      (setq idx 0 count 0))
1675    (setf (aref vector idx) b0)
1676    (incf idx)
1677    (when (= idx limit)
1678      (when (> idx count)
1679        (setf (io-buffer-count buf) idx))
1680      (%ioblock-force-output ioblock nil)
1681      (setq idx 0 count 0))
1682    (setf (aref vector idx) b1)
1683    (incf idx)
1684    (when (= idx limit)
1685      (when (> idx count)
1686        (setf (io-buffer-count buf) idx))
1687      (%ioblock-force-output ioblock nil)
1688      (setq idx 0 count 0))
1689    (setf (aref vector idx) b2)
1690    (incf idx)
1691    (when (= idx limit)
1692      (when (> idx count)
1693        (setf (io-buffer-count buf) idx))
1694      (%ioblock-force-output ioblock nil)
1695      (setq idx 0 count 0))
1696    (setf (aref vector idx) b3)
1697    (incf idx)
1698    (setf (io-buffer-idx buf) idx)
1699    (when (> idx count)
1700      (setf (io-buffer-count buf) idx))
1701    (setf (ioblock-dirty ioblock) t)
1702    element))
1703
1704(declaim (inline %ioblock-write-swapped-u32-code-unit))
1705(defun %ioblock-write-swapped-u32-code-unit (ioblock element)
1706  (declare (optimize (speed 3) (safety 0))
1707           (type (unsigned-byte 16) element))
1708  (let* ((buf (ioblock-outbuf ioblock))
1709         (idx (io-buffer-idx buf))
1710         (count (io-buffer-count buf))
1711         (limit (io-buffer-limit buf))
1712         (vector (io-buffer-buffer buf))
1713         (b0 #+little-endian-target (ldb (byte 8 24) element)
1714             #+big-endian-target (ldb (byte 8 0) element))
1715         (b1 #+little-endian-target (ldb (byte 8 16) element)
1716             #+big-endian-target (ldb (byte 8 8) element))
1717         (b2 #+little-endian-target (ldb (byte 8 8) element)
1718             #+big-endian-target (ldb (byte 8 16) element))
1719         (b3 #+little-endian-target (ldb (byte 8 0) element)
1720             #+big-endian-target (ldb (byte 8 24) element)))
1721    (declare (fixnum idx limit count)
1722             (type (simple-array (unsigned-byte 8) (*)) vector)
1723             (type (unsigned-byte 8) b0 b1 b2 b3))
1724    (when (= idx limit)
1725      (%ioblock-force-output ioblock nil)
1726      (setq idx 0 count 0))
1727    (setf (aref vector idx) b0)
1728    (incf idx)
1729    (when (= idx limit)
1730      (when (> idx count)
1731        (setf (io-buffer-count buf) idx))
1732      (%ioblock-force-output ioblock nil)
1733      (setq idx 0 count 0))
1734    (setf (aref vector idx) b1)
1735    (incf idx)
1736    (when (= idx limit)
1737      (when (> idx count)
1738        (setf (io-buffer-count buf) idx))
1739      (%ioblock-force-output ioblock nil)
1740      (setq idx 0 count 0))
1741    (setf (aref vector idx) b2)
1742    (incf idx)
1743    (when (= idx limit)
1744      (when (> idx count)
1745        (setf (io-buffer-count buf) idx))
1746      (%ioblock-force-output ioblock nil)
1747      (setq idx 0 count 0))
1748    (setf (aref vector idx) b3)
1749    (incf idx)
1750    (setf (io-buffer-idx buf) idx)
1751    (when (> idx count)
1752      (setf (io-buffer-count buf) idx))
1753    (setf (ioblock-dirty ioblock) t)
1754    element))
1755
[5212]1756(declaim (inline %ioblock-write-s16-element))
1757(defun %ioblock-write-s16-element (ioblock element)
1758  (declare (optimize (speed 3) (safety 0)))
1759  (let* ((buf (ioblock-outbuf ioblock))
1760         (idx (io-buffer-idx buf))
1761         (count (io-buffer-count buf))
1762         (limit (io-buffer-limit buf)))
1763    (declare (fixnum idx limit count))
1764    (when (= idx limit)
1765      (%ioblock-force-output ioblock nil)
1766      (setq idx 0 count 0))
1767    (setf (aref (the (simple-array (signed-byte 16) (*)) (io-buffer-buffer buf)) idx) element)
1768    (incf idx)
1769    (setf (io-buffer-idx buf) idx)
1770    (when (> idx count)
1771      (setf (io-buffer-count buf) idx))
1772    (setf (ioblock-dirty ioblock) t)
1773    element))
1774
1775(declaim (inline %ioblock-write-u32-element))
1776(defun %ioblock-write-u32-element (ioblock element)
1777  (declare (optimize (speed 3) (safety 0)))
1778  (let* ((buf (ioblock-outbuf ioblock))
1779         (idx (io-buffer-idx buf))
1780         (count (io-buffer-count buf))
1781         (limit (io-buffer-limit buf)))
1782    (declare (fixnum idx limit count))
1783    (when (= idx limit)
1784      (%ioblock-force-output ioblock nil)
1785      (setq idx 0 count 0))
1786    (setf (aref (the (simple-array (unsigned-byte 32) (*)) (io-buffer-buffer buf)) idx) element)
1787    (incf idx)
1788    (setf (io-buffer-idx buf) idx)
1789    (when (> idx count)
1790      (setf (io-buffer-count buf) idx))
1791    (setf (ioblock-dirty ioblock) t)
1792    element))
1793
[5226]1794(declaim (inline %ioblock-write-swapped-u32-element))
1795(defun %ioblock-write-swapped-u32-element (ioblock element)
1796  (declare (optimize (speed 3) (safety 0)))
1797  (let* ((buf (ioblock-outbuf ioblock))
1798         (idx (io-buffer-idx buf))
1799         (count (io-buffer-count buf))
1800         (limit (io-buffer-limit buf)))
1801    (declare (fixnum idx limit count))
1802    (when (= idx limit)
1803      (%ioblock-force-output ioblock nil)
1804      (setq idx 0 count 0))
1805    (setf (aref (the (simple-array (unsigned-byte 32) (*)) (io-buffer-buffer buf)) idx)
1806          (%swap-u32 element))
1807    (incf idx)
1808    (setf (io-buffer-idx buf) idx)
1809    (when (> idx count)
1810      (setf (io-buffer-count buf) idx))
1811    (setf (ioblock-dirty ioblock) t)
1812    element))
1813
[5212]1814(declaim (inline %ioblock-write-s32-element))
1815(defun %ioblock-write-s32-element (ioblock element)
1816  (declare (optimize (speed 3) (safety 0)))
1817  (let* ((buf (ioblock-outbuf ioblock))
1818         (idx (io-buffer-idx buf))
1819         (count (io-buffer-count buf))
1820         (limit (io-buffer-limit buf)))
1821    (declare (fixnum idx limit count))
1822    (when (= idx limit)
1823      (%ioblock-force-output ioblock nil)
1824      (setq idx 0 count 0))
1825    (setf (aref (the (simple-array (signed-byte 32) (*)) (io-buffer-buffer buf)) idx) element)
1826    (incf idx)
1827    (setf (io-buffer-idx buf) idx)
1828    (when (> idx count)
1829      (setf (io-buffer-count buf) idx))
1830    (setf (ioblock-dirty ioblock) t)
1831    element))
1832
1833#+64-bit-target
1834(progn
1835(declaim (inline %ioblock-write-u64-element))
1836(defun %ioblock-write-u64-element (ioblock element)
1837  (declare (optimize (speed 3) (safety 0)))
1838  (let* ((buf (ioblock-outbuf ioblock))
1839         (idx (io-buffer-idx buf))
1840         (count (io-buffer-count buf))
1841         (limit (io-buffer-limit buf)))
1842    (declare (fixnum idx limit count))
1843    (when (= idx limit)
1844      (%ioblock-force-output ioblock nil)
1845      (setq idx 0 count 0))
1846    (setf (aref (the (simple-array (unsigned-byte 64) (*)) (io-buffer-buffer buf)) idx) element)
1847    (incf idx)
1848    (setf (io-buffer-idx buf) idx)
1849    (when (> idx count)
1850      (setf (io-buffer-count buf) idx))
1851    (setf (ioblock-dirty ioblock) t)
1852    element))
1853
1854(declaim (inline %ioblock-write-s64-element))
1855(defun %ioblock-write-s64-element (ioblock element)
1856  (declare (optimize (speed 3) (safety 0)))
1857  (let* ((buf (ioblock-outbuf ioblock))
1858         (idx (io-buffer-idx buf))
1859         (count (io-buffer-count buf))
1860         (limit (io-buffer-limit buf)))
1861    (declare (fixnum idx limit count))
1862    (when (= idx limit)
1863      (%ioblock-force-output ioblock nil)
1864      (setq idx 0 count 0))
1865    (setf (aref (the (simple-array (signed-byte 64) (*)) (io-buffer-buffer buf)) idx) element)
1866    (incf idx)
1867    (setf (io-buffer-idx buf) idx)
1868    (when (> idx count)
1869      (setf (io-buffer-count buf) idx))
1870    (setf (ioblock-dirty ioblock) t)
1871    element))
1872)
1873
[5202]1874(declaim (inline %ioblock-write-char))
[6]1875(defun %ioblock-write-char (ioblock char)
1876  (declare (optimize (speed 3) (safety 0)))
1877  (if (eq char #\linefeed)
1878    (setf (ioblock-charpos ioblock) 0)
1879    (incf (ioblock-charpos ioblock)))
[5192]1880  (let* ((code (char-code char)))
1881    (declare (type (mod #x110000) code))
1882    (if (< code 256)
1883      (%ioblock-write-u8-element ioblock code)
[5333]1884      (%ioblock-write-u8-element ioblock (char-code #\Sub)))))
[6]1885
[5202]1886(defun %private-ioblock-write-char (ioblock char)
1887  (declare (optimize (speed 3) (safety 0)))
1888  (check-ioblock-owner ioblock)
1889  (%ioblock-write-char ioblock char))
1890
1891(defun %locked-ioblock-write-char (ioblock char)
1892  (declare (optimize (speed 3) (safety 0)))
[5212]1893  (with-ioblock-output-lock-grabbed (ioblock)
[5202]1894    (%ioblock-write-char ioblock char)))
1895
1896(declaim (inline %ioblock-write-u8-encoded-char))
1897(defun %ioblock-write-u8-encoded-char (ioblock char)
1898  (declare (optimize (speed 3) (safety 0)))
1899  (if (eq char #\linefeed)
1900    (setf (ioblock-charpos ioblock) 0)
1901    (incf (ioblock-charpos ioblock)))
1902  (let* ((code (char-code char)))
1903    (declare (type (mod #x110000) code))
[6538]1904    (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock)))
[5202]1905      (%ioblock-write-u8-element ioblock code)
1906      (funcall (ioblock-encode-output-function ioblock)
1907               char
1908               #'%ioblock-write-u8-element
1909               ioblock))))
1910
1911(defun %private-ioblock-write-u8-encoded-char (ioblock char)
1912  (declare (optimize (speed 3) (safety 0)))
1913  (check-ioblock-owner ioblock)
1914  (%ioblock-write-u8-encoded-char ioblock char))
1915
1916(defun %locked-ioblock-write-u8-encoded-char (ioblock char)
1917  (declare (optimize (speed 3) (safety 0)))
[5212]1918  (with-ioblock-output-lock-grabbed (ioblock) 
[5202]1919    (%ioblock-write-u8-encoded-char ioblock char)))
1920
1921
[5226]1922(defun %ioblock-write-u8-encoded-simple-string (ioblock string start-char num-chars)
[5202]1923  (declare (fixnum start-char num-chars)
1924           (simple-base-strng string)
1925           (optimize (speed 3) (safety 0)))
1926  (do* ((i 0 (1+ i))
1927        (col (ioblock-charpos ioblock))
[6538]1928        (limit (ioblock-encode-literal-char-code-limit ioblock))
[5202]1929        (encode-function (ioblock-encode-output-function ioblock))
1930        (start-char start-char (1+ start-char)))
1931       ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
1932    (declare (fixnum i start-char limit))
1933    (let* ((char (schar string start-char))
1934           (code (char-code char)))
1935      (declare (type (mod #x110000) code))
[5333]1936      (if (eq char #\newline)
1937        (setq col 0)
1938        (incf col))
1939      (if (< code limit)
[11627]1940        (%ioblock-write-u8-element ioblock code)
1941        (funcall encode-function char #'%ioblock-write-u8-element ioblock)))))
[5202]1942
[5333]1943
[5226]1944(declaim (inline %ioblock-write-u16-encoded-char))
1945(defun %ioblock-write-u16-encoded-char (ioblock char)
1946  (declare (optimize (speed 3) (safety 0)))
[5264]1947  (when (ioblock-pending-byte-order-mark ioblock)
1948    (setf (ioblock-pending-byte-order-mark ioblock) nil)
[6115]1949    (%ioblock-write-u16-code-unit ioblock byte-order-mark-char-code))
[5226]1950  (if (eq char #\linefeed)
1951    (setf (ioblock-charpos ioblock) 0)
1952    (incf (ioblock-charpos ioblock)))
1953  (let* ((code (char-code char)))
1954    (declare (type (mod #x110000) code))
[6538]1955    (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock)))
[5354]1956      (%ioblock-write-u16-code-unit ioblock code)
[5226]1957      (funcall (ioblock-encode-output-function ioblock)
1958               char
[5306]1959               #'%ioblock-write-u16-code-unit
[5226]1960               ioblock))))
1961
1962(defun %private-ioblock-write-u16-encoded-char (ioblock char)
1963  (declare (optimize (speed 3) (safety 0)))
1964  (check-ioblock-owner ioblock)
1965  (%ioblock-write-u16-encoded-char ioblock char))
1966
1967(defun %locked-ioblock-write-u16-encoded-char (ioblock char)
1968  (declare (optimize (speed 3) (safety 0)))
1969  (with-ioblock-output-lock-grabbed (ioblock)
1970    (%ioblock-write-u16-encoded-char ioblock char)))
1971
[5264]1972
[5226]1973(defun %ioblock-write-u16-encoded-simple-string (ioblock string start-char num-chars)
1974  (declare (fixnum start-char num-chars)
1975           (simple-base-strng string)
1976           (optimize (speed 3) (safety 0)))
[5264]1977  (when (ioblock-pending-byte-order-mark ioblock)
1978    (setf (ioblock-pending-byte-order-mark ioblock) nil)
[5306]1979    (%ioblock-write-u16-code-unit ioblock byte-order-mark-char-code))
[5226]1980  (do* ((i 0 (1+ i))
1981        (col (ioblock-charpos ioblock))
[6538]1982        (limit (ioblock-encode-literal-char-code-limit ioblock))
[5226]1983        (encode-function (ioblock-encode-output-function ioblock))
1984        (start-char start-char (1+ start-char)))
1985       ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
1986    (declare (fixnum i start-char limit))
1987    (let* ((char (schar string start-char))
1988           (code (char-code char)))
1989      (declare (type (mod #x110000) code))
[5335]1990      (if (eq char #\newline)
1991        (setq col 0)
1992        (incf col))
1993      (if (< code limit)
1994        (%ioblock-write-u16-code-unit ioblock code)
1995        (funcall encode-function char #'%ioblock-write-u16-code-unit ioblock)))))
[5226]1996
1997(declaim (inline %ioblock-write-swapped-u16-encoded-char))
1998(defun %ioblock-write-swapped-u16-encoded-char (ioblock char)
1999  (declare (optimize (speed 3) (safety 0)))
2000  (if (eq char #\linefeed)
2001    (setf (ioblock-charpos ioblock) 0)
2002    (incf (ioblock-charpos ioblock)))
2003  (let* ((code (char-code char)))
2004    (declare (type (mod #x110000) code))
[6538]2005    (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock)))
[5306]2006      (%ioblock-write-swapped-u16-code-unit ioblock code)
[5226]2007      (funcall (ioblock-encode-output-function ioblock)
2008               char
[5306]2009               #'%ioblock-write-swapped-u16-code-unit
[5226]2010               ioblock))))
2011
2012(defun %private-ioblock-write-swapped-u16-encoded-char (ioblock char)
2013  (declare (optimize (speed 3) (safety 0)))
2014  (check-ioblock-owner ioblock)
2015  (%ioblock-write-swapped-u16-encoded-char ioblock char))
2016
2017(defun %locked-ioblock-write-swapped-u16-encoded-char (ioblock char)
2018  (declare (optimize (speed 3) (safety 0)))
2019  (with-ioblock-output-lock-grabbed (ioblock)
2020    (%ioblock-write-swapped-u16-encoded-char ioblock char)))
2021
[5264]2022(defun %ioblock-write-swapped-u16-encoded-simple-string (ioblock string start-char num-chars)
2023  (declare (fixnum start-char num-chars)
2024           (simple-base-strng string)
2025           (optimize (speed 3) (safety 0)))
2026  (do* ((i 0 (1+ i))
2027        (col (ioblock-charpos ioblock))
[6538]2028        (limit (ioblock-encode-literal-char-code-limit ioblock))
[5264]2029        (encode-function (ioblock-encode-output-function ioblock))
[5329]2030        (wcf (ioblock-write-char-when-locked-function ioblock))
[5264]2031        (start-char start-char (1+ start-char)))
2032       ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
2033    (declare (fixnum i start-char limit))
2034    (let* ((char (schar string start-char))
2035           (code (char-code char)))
2036      (declare (type (mod #x110000) code))
[5329]2037      (cond ((eq char #\newline)
2038             (setq col 0)
2039             (funcall wcf ioblock char))
2040            (t
2041             (incf col)
2042             (if (< code limit)
2043               (%ioblock-write-swapped-u16-code-unit ioblock code)
2044               (funcall encode-function char #'%ioblock-write-swapped-u16-code-unit ioblock)))))))
[5226]2045
2046
[5354]2047(declaim (inline %ioblock-write-u32-encoded-char))
2048(defun %ioblock-write-u32-encoded-char (ioblock char)
2049  (declare (optimize (speed 3) (safety 0)))
2050  (when (ioblock-pending-byte-order-mark ioblock)
2051    (setf (ioblock-pending-byte-order-mark ioblock) nil)
2052    (%ioblock-write-u32-code-unit ioblock byte-order-mark))
2053  (if (eq char #\linefeed)
2054    (setf (ioblock-charpos ioblock) 0)
2055    (incf (ioblock-charpos ioblock)))
2056  (let* ((code (char-code char)))
2057    (declare (type (mod #x110000 code)))
[6538]2058    (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock)))
[5354]2059      (%ioblock-write-u32-code-unit ioblock code)
2060      (funcall (ioblock-encode-output-function ioblock)
2061               code
2062               #'%ioblock-write-u32-code-unit
2063               ioblock))))
2064
2065(defun %private-ioblock-write-u32-encoded-char (ioblock char)
2066  (declare (optimize (speed 3) (safety 0)))
2067  (check-ioblock-owner ioblock)
2068  (%ioblock-write-u32-encoded-char ioblock char))
2069
2070(defun %locked-ioblock-write-u32-encoded-char (ioblock char)
2071  (declare (optimize (speed 3) (safety 0))) 
2072  (with-ioblock-output-lock-grabbed (ioblock)
2073    (%ioblock-write-u32-encoded-char ioblock char)))
2074
2075(defun %ioblock-write-u32-encoded-simple-string (ioblock string start-char num-chars)
2076  (declare (fixnum start-char num-chars)
2077           (simple-base-strng string)
2078           (optimize (speed 3) (safety 0)))
2079  (when (ioblock-pending-byte-order-mark ioblock)
2080    (setf (ioblock-pending-byte-order-mark ioblock) nil)
2081    (%ioblock-write-u32-code-unit ioblock byte-order-mark-char-code))
2082  (do* ((i 0 (1+ i))
2083        (col (ioblock-charpos ioblock))
[6539]2084        (limit (ioblock-encode-literal-char-code-limit ioblock))
[5354]2085        (encode-function (ioblock-encode-output-function ioblock))
2086        (start-char start-char (1+ start-char)))
2087       ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
2088    (declare (fixnum i start-char limit))
2089    (let* ((char (schar string start-char))
2090           (code (char-code char)))
2091      (declare (type (mod #x110000) code))
2092      (if (eq char #\newline)
2093        (setq col 0)
2094        (incf col))
2095      (if (< code limit)
2096        (%ioblock-write-u32-code-unit ioblock code)
2097        (funcall encode-function char #'%ioblock-write-u32-code-unit ioblock)))))
2098
2099
2100(declaim (inline %ioblock-write-swapped-u32-encoded-char))
2101(defun %ioblock-write-swapped-u32-encoded-char (ioblock char)
2102  (declare (optimize (speed 3) (safety 0)))
2103  (if (eq char #\linefeed)
2104    (setf (ioblock-charpos ioblock) 0)
2105    (incf (ioblock-charpos ioblock)))
2106  (let* ((code (char-code char)))
2107    (declare (type (mod #x110000 code)))
[6538]2108    (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock)))
[5354]2109      (%ioblock-write-swapped-u32-code-unit ioblock code)
2110      (funcall (ioblock-encode-output-function ioblock)
2111               code
2112               #'%ioblock-write-swapped-u32-code-unit
2113               ioblock))))
2114
2115(defun %private-ioblock-write-swapped-u32-encoded-char (ioblock char)
2116  (declare (optimize (speed 3) (safety 0)))
2117  (check-ioblock-owner ioblock)
2118  (%ioblock-write-swapped-u32-encoded-char ioblock char))
2119
2120(defun %locked-ioblock-write-swapped-u32-encoded-char (ioblock char)
2121  (declare (optimize (speed 3) (safety 0))) 
2122  (with-ioblock-output-lock-grabbed (ioblock)
2123    (%ioblock-write-swapped-u32-encoded-char ioblock char)))
2124
2125(defun %ioblock-write-swapped-u32-encoded-simple-string (ioblock string start-char num-chars)
2126  (declare (fixnum start-char num-chars)
2127           (simple-base-strng string)
2128           (optimize (speed 3) (safety 0)))
2129  (do* ((i 0 (1+ i))
2130        (col (ioblock-charpos ioblock))
[6538]2131        (limit (ioblock-encode-literal-char-code-limit ioblock))
[5354]2132        (encode-function (ioblock-encode-output-function ioblock))
2133        (start-char start-char (1+ start-char)))
2134       ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
2135    (declare (fixnum i start-char limit))
2136    (let* ((char (schar string start-char))
2137           (code (char-code char)))
2138      (declare (type (mod #x110000) code))
2139      (if (eq char #\newline)
2140        (setq col 0)
2141        (incf col))
2142      (if (< code limit)
2143        (%ioblock-write-swapped-u32-code-unit ioblock code)
2144        (funcall encode-function char #'%ioblock-write-swapped-u32-code-unit ioblock)))))
2145
[5212]2146(declaim (inline %ioblock-write-u8-byte))
[5208]2147(defun %ioblock-write-u8-byte (ioblock byte)
[6]2148  (declare (optimize (speed 3) (safety 0)))
[5226]2149  (%ioblock-write-u8-element ioblock (require-type byte '(unsigned-byte 8))))
[6]2150
[5212]2151(defun %private-ioblock-write-u8-byte (ioblock byte)
2152  (declare (optimize (speed 3) (safety 0)))
2153  (check-ioblock-owner ioblock)
2154  (%ioblock-write-u8-byte ioblock byte))
2155
2156(defun %locked-ioblock-write-u8-byte (ioblock byte)
2157  (declare (optimize (speed 3) (safety 0)))
2158  (with-ioblock-output-lock-grabbed (ioblock)
2159    (%ioblock-write-u8-byte ioblock byte)))
2160
2161(declaim (inline %ioblock-write-s8-byte))
2162(defun %ioblock-write-s8-byte (ioblock byte)
2163  (declare (optimize (speed 3) (safety 0)))
[5226]2164  (%ioblock-write-s8-element ioblock (require-type byte '(signed-byte 8))))
[5212]2165
2166(defun %private-ioblock-write-s8-byte (ioblock byte)
2167  (declare (optimize (speed 3) (safety 0)))
2168  (check-ioblock-owner ioblock)
2169  (%ioblock-write-s8-byte ioblock byte))
2170
2171(defun %locked-ioblock-write-s8-byte (ioblock byte)
2172  (declare (optimize (speed 3) (safety 0)))
2173  (with-ioblock-output-lock-grabbed (ioblock)
2174    (%ioblock-write-s8-byte ioblock byte)))
2175
2176(declaim (inline %ioblock-write-u16-byte))
2177(defun %ioblock-write-u16-byte (ioblock byte)
2178  (declare (optimize (speed 3) (safety 0)))
[5226]2179  (%ioblock-write-u16-element ioblock (require-type byte '(unsigned-byte 16))))
[5212]2180
2181(defun %private-ioblock-write-u16-byte (ioblock byte)
2182  (declare (optimize (speed 3) (safety 0)))
2183  (check-ioblock-owner ioblock)
2184  (%ioblock-write-u16-byte ioblock byte))
2185
2186(defun %locked-ioblock-write-u16-byte (ioblock byte)
2187  (declare (optimize (speed 3) (safety 0)))
2188  (with-ioblock-output-lock-grabbed (ioblock)
2189    (%ioblock-write-u16-byte ioblock byte)))
2190
2191(declaim (inline %ioblock-write-s16-byte))
2192(defun %ioblock-write-s16-byte (ioblock byte)
2193  (declare (optimize (speed 3) (safety 0)))
[5226]2194  (%ioblock-write-s16-element ioblock (require-type byte '(signed-byte 16))))
[5212]2195
2196(defun %private-ioblock-write-s16-byte (ioblock byte)
2197  (declare (optimize (speed 3) (safety 0)))
2198  (check-ioblock-owner ioblock)
2199  (%ioblock-write-s16-byte ioblock byte))
2200
2201(defun %locked-ioblock-write-s16-byte (ioblock byte)
2202  (declare (optimize (speed 3) (safety 0)))
2203  (with-ioblock-output-lock-grabbed (ioblock)
2204    (%ioblock-write-s16-byte ioblock byte)))
2205
[5226]2206(declaim (inline %ioblock-write-u32-byte))
2207(defun %ioblock-write-u32-byte (ioblock byte)
2208  (declare (optimize (speed 3) (safety 0)))
2209  (%ioblock-write-u32-element ioblock (require-type byte '(unsigned-byte 32))))
[5212]2210
[5226]2211(defun %private-ioblock-write-u32-byte (ioblock byte)
2212  (declare (optimize (speed 3) (safety 0)))
2213  (check-ioblock-owner ioblock)
2214  (%ioblock-write-u32-byte ioblock byte))
[5212]2215
[5226]2216(defun %locked-ioblock-write-u32-byte (ioblock byte)
2217  (declare (optimize (speed 3) (safety 0)))
2218  (with-ioblock-output-lock-grabbed (ioblock)
2219    (%ioblock-write-u32-byte ioblock byte)))
2220
2221(declaim (inline %ioblock-write-s32-byte))
2222(defun %ioblock-write-s32-byte (ioblock byte)
2223  (declare (optimize (speed 3) (safety 0)))
2224  (%ioblock-write-s32-element ioblock (require-type byte '(signed-byte 32))))
2225
2226(defun %private-ioblock-write-s32-byte (ioblock byte)
2227  (declare (optimize (speed 3) (safety 0)))
2228  (check-ioblock-owner ioblock)
2229  (%ioblock-write-s32-byte ioblock byte))
2230
2231(defun %locked-ioblock-write-s32-byte (ioblock byte)
2232  (declare (optimize (speed 3) (safety 0)))
2233  (with-ioblock-output-lock-grabbed (ioblock)
2234    (%ioblock-write-s32-byte ioblock byte)))
2235
2236#+64-bit-target
2237(progn
2238(declaim (inline %ioblock-write-u64-byte))
2239(defun %ioblock-write-u64-byte (ioblock byte)
2240  (declare (optimize (speed 3) (safety 0)))
2241  (%ioblock-write-u64-element ioblock (require-type byte '(unsigned-byte 64))))
2242
2243(defun %private-ioblock-write-u64-byte (ioblock byte)
2244  (declare (optimize (speed 3) (safety 0)))
2245  (check-ioblock-owner ioblock)
2246  (%ioblock-write-u64-byte ioblock byte))
2247
2248(defun %locked-ioblock-write-u64-byte (ioblock byte)
2249  (declare (optimize (speed 3) (safety 0)))
2250  (with-ioblock-output-lock-grabbed (ioblock)
2251    (%ioblock-write-u64-byte ioblock byte)))
2252
2253(declaim (inline %ioblock-write-s64-byte))
2254(defun %ioblock-write-s64-byte (ioblock byte)
2255  (declare (optimize (speed 3) (safety 0)))
2256  (%ioblock-write-s64-element ioblock (require-type byte '(signed-byte 64))))
2257
2258(defun %private-ioblock-write-s64-byte (ioblock byte)
2259  (declare (optimize (speed 3) (safety 0)))
2260  (check-ioblock-owner ioblock)
2261  (%ioblock-write-s64-byte ioblock byte))
2262
2263(defun %locked-ioblock-write-s64-byte (ioblock byte)
2264  (declare (optimize (speed 3) (safety 0)))
2265  (with-ioblock-output-lock-grabbed (ioblock)
2266    (%ioblock-write-s64-byte ioblock byte)))
2267)                                       ;#+64-bit-target
2268
[6]2269(defun %ioblock-clear-output (ioblock)
2270  (let* ((buf (ioblock-outbuf ioblock)))                     
2271    (setf (io-buffer-count buf) 0
2272            (io-buffer-idx buf) 0)))
2273
[5202]2274(defun %ioblock-unencoded-read-line (ioblock)
[5319]2275  (let* ((inbuf (ioblock-inbuf ioblock)))
[5354]2276    (let* ((string "")
2277           (len 0)
2278           (eof nil)
2279           (buf (io-buffer-buffer inbuf))
2280           (newline (char-code #\newline)))
2281      (let* ((ch (ioblock-untyi-char ioblock)))
2282        (when ch
2283          (setf (ioblock-untyi-char ioblock) nil)
2284          (if (eql ch #\newline)
2285            (return-from %ioblock-unencoded-read-line 
2286              (values string nil))
2287            (progn
2288              (setq string (make-string 1)
2289                    len 1)
2290              (setf (schar string 0) ch)))))
2291      (loop
2292        (let* ((more 0)
2293               (idx (io-buffer-idx inbuf))
2294               (count (io-buffer-count inbuf)))
2295          (declare (fixnum idx count more))
2296          (if (= idx count)
2297            (if eof
2298              (return (values string t))
[5319]2299              (progn
[5354]2300                (setq eof t)
2301                (%ioblock-advance ioblock t)))
2302            (progn
2303              (setq eof nil)
2304              (let* ((pos (position newline buf :start idx :end count)))
2305                (when pos
2306                  (locally (declare (fixnum pos))
2307                    (setf (io-buffer-idx inbuf) (the fixnum (1+ pos)))
2308                    (setq more (- pos idx))
2309                    (unless (zerop more)
2310                      (setq string
2311                            (%extend-vector
2312                             0 string (the fixnum (+ len more)))))
2313                    (%copy-u8-to-string
2314                     buf idx string len more)
2315                    (return (values string nil))))
2316                ;; No #\newline in the buffer.  Read everything that's
2317                ;; there into the string, and fill the buffer again.
2318                (setf (io-buffer-idx inbuf) count)
2319                (setq more (- count idx)
2320                      string (%extend-vector
2321                              0 string (the fixnum (+ len more))))
2322                (%copy-u8-to-string
2323                 buf idx string len more)
2324                (incf len more)))))))))
[5245]2325
2326;;; There are lots of ways of doing better here, but in the most general
2327;;; case we can't tell (a) what a newline looks like in the buffer or (b)
2328;;; whether there's a 1:1 mapping between code units and characters.
2329(defun %ioblock-encoded-read-line (ioblock)
2330  (let* ((str (make-array 20 :element-type 'base-char
2331                          :adjustable t :fill-pointer 0))
2332         (rcf (ioblock-read-char-when-locked-function ioblock))
2333         (eof nil))
2334    (do* ((ch (funcall rcf ioblock) (funcall rcf ioblock)))
2335         ((or (eq ch #\newline) (setq eof (eq ch :eof)))
2336          (values (ensure-simple-string str) eof))
2337      (vector-push-extend ch str))))
[6]2338         
[5202]2339(defun %ioblock-unencoded-character-read-vector (ioblock vector start end)
[5335]2340  (do* ((i start)
2341        (in (ioblock-inbuf ioblock))
2342        (inbuf (io-buffer-buffer in))
2343        (need (- end start)))
2344       ((= i end) end)
2345    (declare (fixnum i need))
2346    (let* ((ch (%ioblock-tyi ioblock)))
2347      (if (eq ch :eof)
2348        (return i))
2349      (setf (schar vector i) ch)
2350      (incf i)
2351      (decf need)
2352      (let* ((idx (io-buffer-idx in))
2353             (count (io-buffer-count in))
2354             (avail (- count idx)))
2355        (declare (fixnum idx count avail))
2356        (unless (zerop avail)
2357          (if (> avail need)
2358            (setq avail need))
2359          (%copy-u8-to-string inbuf idx vector i avail)
2360          (setf (io-buffer-idx in) (+ idx avail))
2361          (incf i avail)
2362          (decf need avail))))))
[6]2363
[5335]2364;;; Also used when newline translation complicates things.
[5245]2365(defun %ioblock-encoded-character-read-vector (ioblock vector start end)
2366  (declare (fixnum start end))
2367  (do* ((i start (1+ i))
2368        (rcf (ioblock-read-char-when-locked-function ioblock)))
2369       ((= i end) end)
[9879]2370    (declare (fixnum i))
[5245]2371    (let* ((ch (funcall rcf ioblock)))
2372      (if (eq ch :eof)
2373        (return i))
2374      (setf (schar vector i) ch))))
2375
2376
[6]2377(defun %ioblock-binary-read-vector (ioblock vector start end)
2378  (declare (fixnum start end))
2379  (let* ((in (ioblock-inbuf ioblock))
[5226]2380         (inbuf (io-buffer-buffer in))
2381         (rbf (ioblock-read-byte-when-locked-function ioblock)))
[5427]2382    (setf (ioblock-untyi-char ioblock) nil)
[6]2383    (if (not (= (the fixnum (typecode inbuf))
2384                (the fixnum (typecode vector))))
2385      (do* ((i start (1+ i)))
2386           ((= i end) i)
2387        (declare (fixnum i))
[5226]2388        (let* ((b (funcall rbf ioblock)))
[6]2389          (if (eq b :eof)
2390            (return i)
2391            (setf (uvref vector i) b))))
2392      (do* ((i start)
2393            (need (- end start)))
2394           ((= i end) end)
2395        (declare (fixnum i need))
[5226]2396        (let* ((b (funcall rbf ioblock)))
2397          (if (eq b :eof)
[6]2398            (return i))
[5226]2399          (setf (uvref vector i) b)
[6]2400          (incf i)
2401          (decf need)
2402          (let* ((idx (io-buffer-idx in))
2403                 (count (io-buffer-count in))
2404                 (avail (- count idx)))
2405            (declare (fixnum idx count avail))
2406            (unless (zerop avail)
2407              (if (> avail need)
2408                (setq avail need))
2409              (%copy-ivector-to-ivector
2410               inbuf
2411               (ioblock-elements-to-octets ioblock idx)
2412               vector
2413               (ioblock-elements-to-octets ioblock i)
2414               (ioblock-elements-to-octets ioblock avail))
2415              (setf (io-buffer-idx in) (+ idx avail))
2416              (incf i avail)
2417              (decf need avail))))))))
2418
2419;;; About the same, only less fussy about ivector's element-type.
2420;;; (All fussiness is about the stream's element-type ...).
2421;;; Whatever the element-type is, elements must be 1 octet in size.
2422(defun %ioblock-character-in-ivect (ioblock vector start nb)
2423  (declare (type (simple-array (unsigned-byte 8) (*)) vector)
2424           (fixnum start nb)
2425           (optimize (speed 3) (safety 0)))
2426  (unless (= 0 (the fixnum (ioblock-element-shift ioblock)))
2427    (error "Can't read vector from stream ~s" (ioblock-stream ioblock)))
2428  (do* ((i start)
2429        (in (ioblock-inbuf ioblock))
2430        (inbuf (io-buffer-buffer in))
2431        (need nb)
2432        (end (+ start nb)))
2433       ((= i end) end)
2434    (declare (fixnum i end need))
2435    (let* ((ch (%ioblock-tyi ioblock)))
2436      (if (eq ch :eof)
2437        (return (- i start)))
2438      (setf (aref vector i) (char-code ch))
2439      (incf i)
2440      (decf need)
2441      (let* ((idx (io-buffer-idx in))
2442             (count (io-buffer-count in))
2443             (avail (- count idx)))
2444        (declare (fixnum idx count avail))
2445        (unless (zerop avail)
2446          (if (> avail need)
2447            (setq avail need))
[5202]2448          (%copy-u8-to-string inbuf idx vector i avail)
[6]2449          (setf (io-buffer-idx in) (+ idx avail))
2450          (incf i avail)
2451          (decf need avail))))))
2452
2453(defun %ioblock-binary-in-ivect (ioblock vector start nb)
2454  (declare (type (simple-array (unsigned-byte 8) (*)) vector)
2455           (fixnum start nb)
2456           (optimize (speed 3) (safety 0)))
2457  (unless (= 0 (the fixnum (ioblock-element-shift ioblock)))
2458    (error "Can't read vector from stream ~s" (ioblock-stream ioblock)))
[5427]2459  (setf (ioblock-untyi-char ioblock) nil)
[6]2460  (do* ((i start)
[5226]2461        (rbf (ioblock-read-byte-when-locked-function ioblock))
[6]2462        (in (ioblock-inbuf ioblock))
2463        (inbuf (io-buffer-buffer in))
2464        (need nb)
2465        (end (+ start nb)))
2466       ((= i end) nb)
2467    (declare (fixnum i end need))
[5226]2468    (let* ((b (funcall rbf ioblock)))
[6]2469      (if (eq b :eof)
2470        (return (- i start)))
2471      (setf (uvref vector i) b)
2472      (incf i)
2473      (decf need)
2474      (let* ((idx (io-buffer-idx in))
2475             (count (io-buffer-count in))
2476             (avail (- count idx)))
2477        (declare (fixnum idx count avail))
2478        (unless (zerop avail)
2479          (if (> avail need)
2480            (setq avail need))
2481          (%copy-ivector-to-ivector inbuf idx vector i avail)
2482          (setf (io-buffer-idx in) (+ idx avail))
2483          (incf i avail)
2484          (decf need avail))))))
2485
[9831]2486;;; Thread must own ioblock lock(s).
2487(defun %%ioblock-close (ioblock)
2488  (when (ioblock-device ioblock)
2489    (let* ((stream (ioblock-stream ioblock)))
[6]2490      (funcall (ioblock-close-function ioblock) stream ioblock)
[9831]2491      (setf (ioblock-device ioblock) nil)
[6]2492      (setf (stream-ioblock stream) nil)
2493      (let* ((in-iobuf (ioblock-inbuf ioblock))
2494             (out-iobuf (ioblock-outbuf ioblock))
2495             (in-buffer (if in-iobuf (io-buffer-buffer in-iobuf)))
2496             (in-bufptr (if in-iobuf (io-buffer-bufptr in-iobuf)))
2497             (out-buffer (if out-iobuf (io-buffer-buffer out-iobuf)))
2498             (out-bufptr (if out-iobuf (io-buffer-bufptr out-iobuf))))
2499        (if (and in-buffer in-bufptr)
2500          (%dispose-heap-ivector in-buffer))
2501        (unless (eq in-buffer out-buffer)
2502          (if (and out-buffer out-bufptr)
2503            (%dispose-heap-ivector out-buffer)))
2504        (when in-iobuf
2505          (setf (io-buffer-buffer in-iobuf) nil
2506                (io-buffer-bufptr in-iobuf) nil
2507                (ioblock-inbuf ioblock) nil))
2508        (when out-iobuf
2509          (setf (io-buffer-buffer out-iobuf) nil
2510                (io-buffer-bufptr out-iobuf) nil
[9831]2511                (ioblock-outbuf ioblock) nil))
2512        t))))
[6]2513
[9831]2514(defun %ioblock-close (ioblock)
2515  (let* ((in-lock (ioblock-inbuf-lock ioblock))
2516         (out-lock (ioblock-outbuf-lock ioblock)))
2517    (if in-lock
2518      (with-lock-grabbed (in-lock)
2519        (if (and out-lock (not (eq out-lock in-lock)))
2520          (with-lock-grabbed (out-lock)
2521            (%%ioblock-close ioblock))
2522          (%%ioblock-close ioblock)))
2523      (if out-lock
2524        (with-lock-grabbed (out-lock)
2525          (%%ioblock-close ioblock))
2526        (progn
2527          (check-ioblock-owner ioblock)
2528          (%%ioblock-close ioblock))))))
2529
[6]2530
2531;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2532
[5319]2533;;; Character-at-a-time line-termination-translation functions.
2534;;; It's not always possible to just blast through the buffer, blindly
2535;;; replacing #xd with #xa (for example), and it's not always desirable
2536;;; to do that (if we support changing encoding on open streams.)
2537;;; This is done at a fairly high level; some cases could be done at
2538;;; a lower level, and some cases are hard even at that lower level.
2539;;; This approach doesn't slow down the simple case (when no line-termination
2540;;; translation is used), and hopefully isn't -that- bad.
[6]2541
[5319]2542(declaim (inline %ioblock-read-char-translating-cr-to-newline))
2543(defun %ioblock-read-char-translating-cr-to-newline (ioblock)
2544  (let* ((ch (funcall
[5329]2545              (ioblock-read-char-without-translation-when-locked-function
[5319]2546               ioblock)
2547              ioblock)))
2548    (if (eql ch #\Return)
2549      #\Newline
2550      ch)))
[6]2551
[5319]2552(defun %private-ioblock-read-char-translating-cr-to-newline (ioblock)
2553  (check-ioblock-owner ioblock)
2554  (%ioblock-read-char-translating-cr-to-newline ioblock))
2555
2556(defun %locked-ioblock-read-char-translating-cr-to-newline (ioblock)
2557  (with-ioblock-input-lock-grabbed (ioblock)
2558    (%ioblock-read-char-translating-cr-to-newline ioblock)))
2559
2560(declaim (inline %ioblock-read-char-translating-crlf-to-newline))
2561(defun %ioblock-read-char-translating-crlf-to-newline (ioblock)
2562  (let* ((ch (funcall
[5329]2563              (ioblock-read-char-without-translation-when-locked-function
[5319]2564               ioblock)
2565              ioblock)))
2566    (if (eql ch #\Return)
2567      (let* ((next (funcall
[5329]2568                    (ioblock-read-char-without-translation-when-locked-function
[5319]2569                     ioblock)
2570                    ioblock)))
2571        (if (eql next #\Linefeed)
2572          next
2573          (progn
2574            (unless (eq next :eof)
2575              (setf (ioblock-untyi-char ioblock) next))
2576            ch)))
2577      ch)))
2578   
2579(defun %private-ioblock-read-char-translating-crlf-to-newline (ioblock)
2580  (check-ioblock-owner ioblock)
2581  (%ioblock-read-char-translating-crlf-to-newline ioblock))
2582
2583(defun %locked-ioblock-read-char-translating-crlf-to-newline (ioblock)
2584  (with-ioblock-input-lock-grabbed (ioblock)
2585    (%ioblock-read-char-translating-crlf-to-newline ioblock)))
2586
2587(declaim (inline %ioblock-read-char-translating-line-separator-to-newline))
2588(defun %ioblock-read-char-translating-line-separator-to-newline (ioblock)
2589  (let* ((ch (funcall
[5329]2590              (ioblock-read-char-without-translation-when-locked-function
[5319]2591               ioblock)
2592              ioblock)))
2593    (if (eql ch #\Line_Separator)
2594      #\Newline
2595      ch)))
2596
2597(defun %private-ioblock-read-char-translating-line-separator-to-newline (ioblock)
2598  (check-ioblock-owner ioblock)
2599  (%ioblock-read-char-translating-line-separator-to-newline ioblock))
2600
2601(defun %locked-ioblock-read-char-translating-line-separator-to-newline (ioblock)
2602  (with-ioblock-input-lock-grabbed (ioblock)
2603    (%ioblock-read-char-translating-line-separator-to-newline ioblock)))
2604
2605(declaim (inline %ioblock-write-char-translating-newline-to-cr))
2606(defun %ioblock-write-char-translating-newline-to-cr (ioblock char)
[5329]2607  (funcall (ioblock-write-char-without-translation-when-locked-function
[5319]2608            ioblock)
2609           ioblock
2610           (if (eql char #\Newline) #\Return char)))
2611
2612(defun %private-ioblock-write-char-translating-newline-to-cr (ioblock char)
2613  (check-ioblock-owner ioblock)
2614  (%ioblock-write-char-translating-newline-to-cr ioblock char))
2615
2616(defun %locked-ioblock-write-char-translating-newline-to-cr (ioblock char)
2617  (with-ioblock-input-lock-grabbed (ioblock)
2618    (%ioblock-write-char-translating-newline-to-cr ioblock char)))
2619
2620(declaim (inline %ioblock-write-char-translating-newline-to-crlf))
2621(defun %ioblock-write-char-translating-newline-to-crlf (ioblock char)
2622  (when (eql char #\Newline)
[5329]2623    (funcall (ioblock-write-char-without-translation-when-locked-function
[5319]2624              ioblock)
2625             ioblock
2626             #\Return))   
[5329]2627  (funcall (ioblock-write-char-without-translation-when-locked-function
[5319]2628            ioblock)
2629           ioblock
2630           char))
2631
2632(defun %private-ioblock-write-char-translating-newline-to-crlf (ioblock char)
2633  (check-ioblock-owner ioblock)
2634  (%ioblock-write-char-translating-newline-to-crlf ioblock char))
2635
2636(defun %locked-ioblock-write-char-translating-newline-to-crlf (ioblock char)
2637  (with-ioblock-input-lock-grabbed (ioblock)
2638    (%ioblock-write-char-translating-newline-to-crlf ioblock char)))
2639
2640(declaim (inline %ioblock-write-char-translating-newline-to-line-separator))
2641(defun %ioblock-write-char-translating-newline-to-line-separator (ioblock char)
[5329]2642  (funcall (ioblock-write-char-without-translation-when-locked-function
[5319]2643            ioblock)
2644           ioblock
2645           (if (eql char #\Newline) #\Line_Separator char)))
2646
2647(defun %private-ioblock-write-char-translating-newline-to-line-separator (ioblock char)
2648  (check-ioblock-owner ioblock)
2649  (%ioblock-write-char-translating-newline-to-line-separator ioblock char))
2650
2651(defun %locked-ioblock-write-char-translating-newline-to-line-separator (ioblock char)
2652  (with-ioblock-input-lock-grabbed (ioblock)
2653    (%ioblock-write-char-translating-newline-to-line-separator ioblock char)))
[5335]2654
2655;;; If we do newline translation, we probably can't be too clever about reading/writing
2656;;; strings.
2657(defun %ioblock-write-simple-string-with-newline-translation (ioblock string start-pos num-chars)
[9879]2658  (declare (fixnum start-pos num-chars) (simple-string string))
[5335]2659  (let* ((col (ioblock-charpos ioblock))
2660         (wcf (ioblock-write-char-when-locked-function ioblock)))
2661    (declare (fixnum col))
2662    (do* ((i start-pos (1+ i))
2663          (n 0 (1+ n)))
2664         ((= n num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
2665      (let* ((char (schar string i)))
2666        (if (eql char #\Newline)
2667          (setq col 0)
2668          (incf col))
2669        (funcall wcf ioblock char)))))
2670
[5319]2671
2672;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
2673
2674(defun setup-ioblock-input (ioblock character-p element-type sharing encoding line-termination)
[5329]2675  (setf (ioblock-sharing ioblock) sharing)
[4918]2676  (when character-p
[11627]2677    (setf (ioblock-unread-char-function ioblock) (select-stream-untyi-function (ioblock-stream ioblock) :input))
[7316]2678    (setf (ioblock-decode-literal-code-unit-limit ioblock)
2679          (if encoding
2680            (character-encoding-decode-literal-code-unit-limit encoding)
2681            256))   
[5202]2682    (if encoding
2683      (let* ((unit-size (character-encoding-code-unit-size encoding)))
[5245]2684        (setf (ioblock-peek-char-function ioblock) '%encoded-ioblock-peek-char)
2685        (setf (ioblock-read-line-function ioblock)
2686              '%ioblock-encoded-read-line)
2687        (setf (ioblock-character-read-vector-function ioblock)
2688              '%ioblock-encoded-character-read-vector)       
[5202]2689        (setf (ioblock-decode-input-function ioblock)
2690              (character-encoding-stream-decode-function encoding))
2691        (setf (ioblock-read-char-function ioblock)
2692              (ecase unit-size
2693                (8
[5226]2694                 (setf (ioblock-read-char-when-locked-function ioblock)
2695                       '%ioblock-read-u8-encoded-char)
[5202]2696                 (case sharing
2697                   (:private '%private-ioblock-read-u8-encoded-char)
2698                   (:lock '%locked-ioblock-read-u8-encoded-char)
[5264]2699                   (t '%ioblock-read-u8-encoded-char)))
2700                (16
2701                 (if (character-encoding-native-endianness encoding)
2702                   (progn
2703                    (setf (ioblock-read-char-when-locked-function ioblock)
2704                          '%ioblock-read-u16-encoded-char)
2705                    (case sharing
2706                      (:private '%private-ioblock-read-u16-encoded-char)
2707                      (:lock '%locked-ioblock-read-u16-encoded-char)
2708                      (t '%ioblock-read-u16-encoded-char)))
2709                   (progn
2710                     (setf (ioblock-read-char-when-locked-function ioblock)
2711                           '%ioblock-read-swapped-u16-encoded-char)
2712                    (case sharing
2713                      (:private '%private-ioblock-read-swapped-u16-encoded-char)
2714                      (:lock '%locked-ioblock-read-swapped-u16-encoded-char)
[5354]2715                      (t '%ioblock-read-swapped-u16-encoded-char)))))
2716                (32
2717                 (if (character-encoding-native-endianness encoding)
2718                   (progn
2719                    (setf (ioblock-read-char-when-locked-function ioblock)
2720                          #'%ioblock-read-u32-encoded-char)
2721                    (case sharing
2722                      (:private #'%private-ioblock-read-u32-encoded-char)
2723                      (:lock #'%locked-ioblock-read-u32-encoded-char)
2724                      (t #'%ioblock-read-u32-encoded-char)))
2725                   (progn
2726                     (setf (ioblock-read-char-when-locked-function ioblock)
2727                           #'%ioblock-read-swapped-u32-encoded-char)
2728                    (case sharing
2729                      (:private '#'%private-ioblock-read-swapped-u16-encoded-char)
2730                      (:lock #'%locked-ioblock-read-swapped-u32-encoded-char)
2731                      (t #'%ioblock-read-swapped-u32-encoded-char))))))))
[5202]2732      (progn
[5245]2733        (setf (ioblock-peek-char-function ioblock) '%ioblock-peek-char)
[5202]2734        (setf (ioblock-read-char-function ioblock)
2735              (case sharing
2736                (:private '%private-ioblock-tyi)
2737                (:lock '%locked-ioblock-tyi)
2738                (t '%ioblock-tyi)))
[5226]2739        (setf (ioblock-read-char-when-locked-function ioblock)
2740              '%ioblock-tyi)
[5202]2741        (setf (ioblock-character-read-vector-function ioblock)
2742              '%ioblock-unencoded-character-read-vector)
2743        (setf (ioblock-read-line-function ioblock)
[5319]2744              '%ioblock-unencoded-read-line)))
[5329]2745    (when line-termination
[5335]2746      (install-ioblock-input-line-termination ioblock line-termination))
2747    )
[5329]2748
[4918]2749  (unless (or (eq element-type 'character)
2750              (subtypep element-type 'character))
2751    (let* ((subtag (element-type-subtype element-type)))
2752      (declare (type (unsigned-byte 8) subtag))
2753      (setf (ioblock-read-byte-function ioblock)
2754            (cond ((= subtag target::subtag-u8-vector)
2755                   (if character-p
2756                     ;; The bivalent case, at least for now
[5226]2757                     (progn
2758                       (setf (ioblock-read-byte-when-locked-function ioblock)
2759                             '%bivalent-ioblock-read-u8-byte)
2760                       (case sharing
2761                         (:private '%bivalent-private-ioblock-read-u8-byte)
2762                         (:lock '%bivalent-locked-ioblock-read-u8-byte)
2763                         (t '%bivalent-ioblock-read-u8-byte)))
2764                     (progn
2765                       (setf (ioblock-read-byte-when-locked-function ioblock)
2766                             '%ioblock-read-u8-byte)
2767                       (case sharing
2768                         (:private '%private-ioblock-read-u8-byte)
2769                         (:lock '%locked-ioblock-read-u8-byte)
2770                         (t '%ioblock-read-u8-byte)))))
[5212]2771                  ((= subtag target::subtag-s8-vector)
[5226]2772                   (setf (ioblock-read-byte-when-locked-function ioblock)
2773                         '%ioblock-read-s8-byte) 
2774                   (case sharing
2775                     (:private '%private-ioblock-read-s8-byte)
2776                     (:lock '%locked-ioblock-read-s8-byte)
2777                     (t '%ioblock-read-s8-byte)))
[5212]2778                  ((= subtag target::subtag-u16-vector)
[5226]2779                   (setf (ioblock-read-byte-when-locked-function ioblock)
2780                         '%ioblock-read-u16-byte)
2781                   (case sharing
2782                     (:private '%private-ioblock-read-u16-byte)
2783                     (:lock '%locked-ioblock-read-u16-byte)
2784                     (t '%ioblock-read-u16-byte)))
[5212]2785                  ((= subtag target::subtag-s16-vector)
[5226]2786                   (setf (ioblock-read-byte-when-locked-function ioblock)
2787                         '%ioblock-read-s16-byte)
2788                   (case sharing
2789                     (:private '%private-ioblock-read-s16-byte)
2790                     (:lock '%locked-ioblock-read-s16-byte)
2791                     (t '%ioblock-read-s16-byte)))
[5212]2792                  ((= subtag target::subtag-u32-vector)
[5226]2793                   (setf (ioblock-read-byte-when-locked-function ioblock)
2794                         '%ioblock-read-u32-byte)
2795                   (case sharing
2796                     (:private '%private-ioblock-read-u32-byte)
2797                     (:lock '%locked-ioblock-read-u32-byte)
2798                     (t '%ioblock-read-u32-byte)))
[5212]2799                  ((= subtag target::subtag-s32-vector)
[5226]2800                   (setf (ioblock-read-byte-when-locked-function ioblock)
2801                         '%ioblock-read-s32-byte)                   
2802                   (case sharing
2803                     (:private '%private-ioblock-read-s32-byte)
2804                     (:lock '%locked-ioblock-read-s32-byte)
2805                     (t '%ioblock-read-s32-byte)))
[5212]2806                  #+64-bit-target
2807                  ((= subtag target::subtag-u64-vector)
[5226]2808                   (setf (ioblock-read-byte-when-locked-function ioblock)
2809                         '%ioblock-read-u64-byte)                   
2810                   (case sharing
2811                     (:private '%private-ioblock-read-u64-byte)
2812                     (:lock '%locked-ioblock-read-u64-byte)
2813                     (t '%ioblock-read-u64-byte)))
[5212]2814                  #+64-bit-target
2815                  ((= subtag target::subtag-s64-vector)
[5226]2816                   (setf (ioblock-read-byte-when-locked-function ioblock)
2817                         '%ioblock-read-s64-byte)
2818                   (case sharing
2819                     (:private '%private-ioblock-read-s64-byte)
2820                     (:lock '%locked-ioblock-read-s64-byte)
2821                     (t '%ioblock-read-s64-byte)))
2822                  ;; Not sure what this means, currently.
2823                  (t
2824                   (setf (ioblock-read-byte-when-locked-function ioblock)
2825                         '%general-ioblock-read-byte)
2826                   '%general-ioblock-read-byte))))))
[6]2827
[5335]2828(defun install-ioblock-input-line-termination (ioblock line-termination)
2829  (when line-termination
2830    (let* ((sharing (ioblock-sharing ioblock)))
2831      (setf (ioblock-read-char-without-translation-when-locked-function ioblock)
2832            (ioblock-read-char-when-locked-function ioblock)
2833            (ioblock-character-read-vector-function ioblock)
2834            '%ioblock-encoded-character-read-vector
2835            (ioblock-read-line-function ioblock) '%ioblock-encoded-read-line)
2836      (ecase line-termination
2837        (:cr (setf (ioblock-read-char-when-locked-function ioblock)
2838                   '%ioblock-read-char-translating-cr-to-newline
2839                   (ioblock-read-char-function ioblock)
2840                   (case sharing
2841                     (:private
2842                      '%private-ioblock-read-char-translating-cr-to-newline)
2843                     (:lock
2844                      '%locked-ioblock-read-char-translating-cr-to-newline)
2845                     (t '%ioblock-read-char-translating-cr-to-newline))))
2846        (:crlf (setf (ioblock-read-char-when-locked-function ioblock)
2847                     '%ioblock-read-char-translating-crlf-to-newline
2848                     (ioblock-read-char-function ioblock)
2849                     (case sharing
2850                       (:private
2851                        '%private-ioblock-read-char-translating-crlf-to-newline)
2852                       (:lock
2853                        '%locked-ioblock-read-char-translating-crlf-to-newline)
2854                       (t '%ioblock-read-char-translating-crlf-to-newline))))
2855        (:unicode (setf (ioblock-read-char-when-locked-function ioblock)
2856                        '%ioblock-read-char-translating-line-separator-to-newline
2857                        (ioblock-read-char-function ioblock)
2858                        (case sharing
2859                          (:private
2860                           '%private-ioblock-read-char-translating-line-separator-to-newline)
2861                          (:lock
2862                           '%locked-ioblock-read-char-translating-line-separator-to-newline)
2863                          (t '%ioblock-read-char-translating-line-separator-to-newline))))))))
2864 
[5319]2865(defun setup-ioblock-output (ioblock character-p element-type sharing encoding line-termination)
[5329]2866  (or (ioblock-sharing ioblock)
2867      (setf (ioblock-sharing ioblock) sharing))
[5202]2868  (when character-p
[7316]2869    (setf (ioblock-encode-literal-char-code-limit ioblock)
2870          (if encoding
2871            (character-encoding-encode-literal-char-code-limit encoding)
2872            256))   
[5202]2873    (if encoding
2874      (let* ((unit-size (character-encoding-code-unit-size encoding)))
2875        (setf (ioblock-encode-output-function ioblock)
2876              (character-encoding-stream-encode-function encoding))
2877        (setf (ioblock-write-char-function ioblock)
2878              (ecase unit-size
2879                (8
[5226]2880                 (setf (ioblock-write-char-when-locked-function ioblock)
[5329]2881                       '%ioblock-write-u8-encoded-char) 
[5202]2882                 (case sharing
2883                   (:private '%private-ioblock-write-u8-encoded-char)
[5245]2884                   (:lock '%locked-ioblock-write-u8-encoded-char)
[5264]2885                   (t '%ioblock-write-u8-encoded-char)))
2886                (16
2887                 (if (character-encoding-native-endianness encoding)
2888                   (progn
2889                     (setf (ioblock-write-char-when-locked-function ioblock)
2890                           '%ioblock-write-u16-encoded-char) 
2891                     (case sharing
2892                       (:private '%private-ioblock-write-u16-encoded-char)
2893                       (:lock '%locked-ioblock-write-u16-encoded-char)
2894                       (t '%ioblock-write-u16-encoded-char)))
2895                   (progn
2896                     (setf (ioblock-write-char-when-locked-function ioblock)
2897                           '%ioblock-write-swapped-u16-encoded-char)
2898                     (case sharing
2899                       (:private '%private-ioblock-write-swapped-u16-encoded-char)
2900                       (:lock '%locked-ioblock-write-swapped-u16-encoded-char)
[5354]2901                       (t '%ioblock-write-swapped-u16-encoded-char)))))
2902                (32
2903                 (if (character-encoding-native-endianness encoding)
2904                   (progn
2905                     (setf (ioblock-write-char-when-locked-function ioblock)
2906                           #'%ioblock-write-u32-encoded-char) 
2907                     (case sharing
2908                       (:private #'%private-ioblock-write-u32-encoded-char)
2909                       (:lock #'%locked-ioblock-write-u32-encoded-char)
2910