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

Last change on this file since 14397 was 14397, checked in by gb, 9 years ago

Try to make string-output-stream creation a little faster.
Amazingly enough, not creating a string-output-stream is still
faster than creating one is.

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