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

Last change on this file since 15536 was 15536, checked in by gb, 7 years ago

Support using the "coding" option in a file's file options line (a
line at the start of a text file that contains name:value pairs
separated by semicolons bracketed by -*- sequences) to determine a
file's character encoding. Specifically:

  • OPEN now allows an external-format of :INFERRED; previously, this was shorthand for an external-format whose line-termination was inferred and whose character encoding was based on *DEFAULT-FILE-CHARACTER-ENCODING*. When an input file whose external-format is specified as :INFERRED is opened, its file options are parsed and the value of the "coding" option is used if such an option is found (and if the value is something that CCL supports.) If a supported "coding" option isn't found, *DEFAULT-FILE-CHARACTER-ENCODING* is used as before.
  • In the Cocoa IDE, the Hemlock command "Ensure File Options Line" (bound to Control-Meta-M by default) ensures that the first line in the current buffer is a file options line and fills in some plausible values for the "Mode", "Package", and "Coding" options. The "Process File Options" command (Control-Meta-m) can be used to process the file options line after it's been edited. (The file options line is always processed when the file is first opened; changes to the "coding" option affect how the file will be saved.)

When a Lisp source file is opened in the IDE editor, the following
character encodings are tried in this order until one of them
succeeds:

  • if the "Open ..." panel was used to open the file and an encoding other than "Automatic" - which is now the default - is selected, that encoding is tried.
  • if a "coding" option is found, that encoding is tried.
  • the value of *DEFAULT-FILE-CHARACTER-ENCODING* is tried.
  • iso-8859-1 is tried. All files can be decoded in iso-8859-1.

This is all supposed to be what Emacs does and I think that it's
pretty close in practice.

A file that caused problems for Paul Krueger a few days ago
because its encoding (ISO-8859-1) wasn't guessed correctly
now has an explicit "coding" option and serves as a test case.

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