source: branches/1.2-devel/ccl/level-1/l1-streams.lisp @ 7970

;;;-*-Mode: LISP; Package: CCL -*-
;;;
;;;   Copyright (C) 1994-2001 Digitool, Inc
;;;   Portions copyright (C) 2001 Clozure Associates
;;;   This file is part of OpenMCL.  
;;;
;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
;;;   License , known as the LLGPL and distributed with OpenMCL as the
;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
;;;   conflict, the preamble takes precedence.  
;;;
;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
;;;
;;;   The LLGPL is also available online at
;;;   http://opensource.franz.com/preamble.html

(in-package "CCL")

(eval-when (:compile-toplevel :execute)
  #+linuxppc-target
  (require "PPC-LINUX-SYSCALLS")
  #+linuxx8664-target
  (require "X8664-LINUX-SYSCALLS")
  #+darwinppc-target
  (require "DARWINPPC-SYSCALLS")
  #+darwinx8664-target
  (require "DARWINX8664-SYSCALLS")
  #+freebsdx8664-target
  (require "X8664-FREEBSD-SYSCALLS"))

;;;

(defclass stream ()
  ())


(defclass input-stream (stream)
  ())


(defclass output-stream (stream) ())

(defmethod stream-direction ((s stream))
  )

(defmethod stream-domain ((s stream))
  t)


(defmethod stream-direction ((s input-stream))
  (if (typep s 'output-stream)
    :io
    :input))

(defmethod stream-direction ((s output-stream))
  (if (typep s 'input-stream)
    :io
    :output))

;;; Try to return a string containing characters that're near the
;;; stream's current position, if that makes sense.  Return NIL
;;; if it doesn't make sense.
;;; Some things (SOCKET-ERRORs) are signaled as STREAM-ERRORs
;;; whose STREAM args aren't streams.  That's wrong, but
;;; defining this method on T keeps things from blowing up worse.
(defmethod stream-surrounding-characters ((s t))
  (declare (ignore s))
  nil)


;;; The "direction" argument only helps us dispatch on two-way streams:
;;; it's legal to ask for the :output device of a stream that's only open
;;; for input, and one might get a non-null answer in that case.
(defmethod stream-device ((s stream) direction)
  (declare (ignore direction)))

;;; Some generic stream functions:
(defmethod stream-length ((x t) &optional new)
  (declare (ignore new))
  (report-bad-arg x 'stream))

(defmethod stream-position ((x t) &optional new)
  (declare (ignore new))
  (report-bad-arg x 'stream))

(defmethod stream-element-type ((x t))
  (report-bad-arg x 'stream))

(defmethod stream-position ((s stream) &optional newpos)
  (declare (ignore newpos)))

;;; For input streams:

;; From Shannon Spires, slightly modified.
(defun generic-read-line (s)
  (let* ((str (make-array 20 :element-type 'base-char
                          :adjustable t :fill-pointer 0))
         (eof nil))
    (do* ((ch (read-char s nil :eof) (read-char s nil :eof)))
         ((or (eq ch #\newline) (setq eof (eq ch :eof)))
          (values (ensure-simple-string str) eof))
      (vector-push-extend ch str))))

(defun generic-character-read-list (stream list count)
  (declare (fixnum count))
  (do* ((tail list (cdr tail))
        (i 0 (1+ i)))
       ((= i count) count)
    (declare (fixnum i))
    (let* ((ch (read-char stream nil :eof)))
      (if (eq ch :eof)
        (return i)
        (rplaca tail ch)))))

(defun generic-binary-read-list (stream list count)
  (declare (fixnum count))
  (do* ((tail list (cdr tail))
        (i 0 (1+ i)))
       ((= i count) count)
    (declare (fixnum i))
    (let* ((ch (stream-read-byte stream)))
      (if (eq ch :eof)
        (return i)
        (rplaca tail ch)))))

(defun generic-character-read-vector (stream vector start end)
  (declare (fixnum start end))
  (do* ((i start (1+ i)))
       ((= i end) end)
    (declare (fixnum i))
    (let* ((ch (stream-read-char stream)))
      (if (eq ch :eof)
        (return i)
        (setf (uvref vector i) ch)))))

(defun generic-binary-read-vector (stream vector start end)
  (declare (fixnum start end))
  (do* ((i start (1+ i)))
       ((= i end) end)
    (declare (fixnum i))
    (let* ((byte (stream-read-byte stream)))
      (if (eq byte :eof)
        (return i)
        (setf (uvref vector i) byte)))))


;;; For output streams:

(defun generic-advance-to-column (s col)
  (let* ((current (column s)))
    (unless (null current)
      (when (< current col)
        (do* ((i current (1+ i)))
             ((= i col))
          (write-char #\Space s)))
      t)))



(defun generic-stream-write-string (stream string start end)
  (setq end (check-sequence-bounds string start end))
  (locally (declare (fixnum start end))
    (multiple-value-bind (vect offset) (array-data-and-offset string)
      (declare (fixnum offset))
      (unless (zerop offset)
        (incf start offset)
        (incf end offset))
      (do* ((i start (1+ i)))
           ((= i end) string)
        (declare (fixnum i))
        (write-char (schar vect i) stream)))))












(defloadvar *heap-ivectors* ())
(defvar *heap-ivector-lock* (make-lock))



(defun %make-heap-ivector (subtype size-in-bytes size-in-elts)
  (with-macptrs ((ptr (malloc (+ size-in-bytes
                                 #+32-bit-target (+ 4 2 7) ; 4 for header, 2 for delta, 7 for round up
                                 #+64-bit-target (+ 8 2 15) ; 8 for header, 2 for delta, 15 for round up
                                 ))))
    (let ((vect (fudge-heap-pointer ptr subtype size-in-elts))
          (p (%null-ptr)))
      (%vect-data-to-macptr vect p)
      (with-lock-grabbed (*heap-ivector-lock*)
        (push vect *heap-ivectors*))
      (values vect p))))

(defun %heap-ivector-p (v)
  (with-lock-grabbed (*heap-ivector-lock*)
    (not (null (member v *heap-ivectors* :test #'eq)))))


(defun dispose-heap-ivector (v)
  (if (%heap-ivector-p v)
    (with-macptrs (p)
      (with-lock-grabbed (*heap-ivector-lock*)
        (setq *heap-ivectors* (delq v *heap-ivectors*)))
      (%%make-disposable p v)
      (free p))))

(defun %dispose-heap-ivector (v)
  (dispose-heap-ivector v))

(defun make-heap-ivector (element-count element-type)
  (let* ((subtag (ccl::element-type-subtype element-type)))
    (unless
        #+ppc32-target
        (= (logand subtag ppc32::fulltagmask)
               ppc32::fulltag-immheader)
        #+ppc64-target
        (= (logand subtag ppc64::lowtagmask)
           ppc64::lowtag-immheader)
        #+x8664-target
        (logbitp (the (mod 16) (logand subtag x8664::fulltagmask))
                 (logior (ash 1 x8664::fulltag-immheader-0)
                         (ash 1 x8664::fulltag-immheader-1)
                         (ash 1 x8664::fulltag-immheader-2)))
      (error "~s is not an ivector subtype." element-type))
    (let* ((size-in-octets (ccl::subtag-bytes subtag element-count)))
      (multiple-value-bind (pointer vector)
          (ccl::%make-heap-ivector subtag size-in-octets element-count)
        (values pointer vector size-in-octets)))))









(defvar *elements-per-buffer* 2048)  ; default buffer size for file io

(defmethod streamp ((x t))
  nil)

(defmethod streamp ((x stream))
  t)

(defmethod stream-io-error ((stream stream) error-number context)
  (error 'simple-stream-error :stream stream
         :format-control (format nil "~a during ~a"
                                 (%strerror error-number) context)))



(defmethod stream-write-char ((stream stream) char)
  (declare (ignore char))
  (error "stream ~S is not capable of output" stream))

(defun stream-write-entire-string (stream string)
  (stream-write-string stream string))


(defmethod stream-read-char ((x t))
  (report-bad-arg x 'stream))

(defmethod stream-read-char ((stream stream))
  (error "~s is not capable of input" stream))

(defmethod stream-unread-char ((x t) char)
  (declare (ignore char))
  (report-bad-arg x 'stream))

(defmethod stream-unread-char ((stream stream) char)
  (declare (ignore char))
  (error "stream ~S is not capable of input" stream))



(defmethod stream-force-output ((stream output-stream)) nil)
(defmethod stream-maybe-force-output ((stream stream))
  (stream-force-output stream))

(defmethod stream-finish-output ((stream output-stream)) nil)



(defmethod stream-clear-output ((stream output-stream)) nil)

(defmethod close ((stream stream) &key abort)
  (declare (ignore abort))
  (open-stream-p stream))



(defmethod open-stream-p ((x t))
  (report-bad-arg x 'stream))

(defmethod open-stream-p ((stream stream))
  t)

(defmethod stream-external-format ((x t))
  (report-bad-arg x 'stream))

(defmethod stream-external-format ((s stream))
  nil)


(defmethod (setf stream-external-format) (new (s t))
  (normalize-external-format (stream-domain s) new)
  (report-bad-arg s 'stream))



    
(defmethod stream-fresh-line ((stream output-stream))
  (terpri stream)
  t)

(defmethod stream-line-length ((stream stream))
  "This is meant to be shadowed by particular kinds of streams,
   esp those associated with windows."
  80)

(defmethod interactive-stream-p ((x t))
  (report-bad-arg x 'stream))

(defmethod interactive-stream-p ((stream stream)) nil)

(defmethod stream-clear-input ((x t))
  (report-bad-arg x 'stream))

(defmethod stream-clear-input ((stream input-stream)) nil)

(defmethod stream-listen ((stream input-stream))
  (not (eofp stream)))

(defmethod stream-filename ((stream stream))
  (report-bad-arg stream 'file-stream))




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; For input streams, the IO-BUFFER-COUNT field denotes the number
;;; of elements read from the underlying input source (e.g., the
;;; file system.)  For output streams, it's the high-water mark of
;;; elements output to the buffer.

(defstruct io-buffer
  (buffer nil :type (or (simple-array * (*)) null))
  (bufptr nil :type (or macptr null))
  (size 0 :type fixnum)                 ; size (in octets) of buffer
  (idx 0 :type fixnum)                  ; index of next element
  (count 0 :type fixnum)                ; count of active elements
  (limit 0 :type fixnum)                ; size (in elements) of buffer
  (translate nil)                       ; newline-translation
  )

(defmethod print-object ((buf io-buffer) out)
  (print-unreadable-object (buf out :identity t :type t)
    (let* ((buffer (io-buffer-buffer buf)))
      (when buffer (format out " ~s " (array-element-type buffer))))
    (format out "~d/~d/~d"
            (io-buffer-idx buf)
            (io-buffer-count buf)
            (io-buffer-limit buf))))

(defstruct ioblock
  stream                                ; the stream being buffered
  untyi-char                            ; nil or last value passed to
                                        ;  stream-unread-char
  (inbuf nil :type (or null io-buffer))
  (outbuf nil :type (or null io-buffer))
  (element-type 'character)
  (element-shift 0 :type fixnum)        ;element shift count
  (charpos 0 :type (or nil fixnum))     ;position of cursor
  (device -1 :type fixnum)              ;file descriptor
  (advance-function 'ioblock-advance)
  (listen-function 'ioblock-listen)
  (eofp-function 'ioblock-eofp)
  (force-output-function 'ioblock-force-output)
  (close-function 'ioblock-close)
  (inbuf-lock nil)
  (eof nil)
  (interactive nil)
  (dirty nil)
  (outbuf-lock nil)
  (owner nil)
  (read-char-function 'ioblock-no-char-input)
  (read-byte-function 'ioblock-no-binary-input)
  (write-byte-function 'ioblock-no-binary-output)
  (write-char-function 'ioblock-no-char-output)
  (encoding nil)
  (pending-byte-order-mark nil)
  (decode-literal-code-unit-limit 256)
  (encode-output-function nil)
  (decode-input-function nil)
  (read-char-when-locked-function 'ioblock-no-char-input)
  (write-simple-string-function 'ioblock-no-char-output)
  (character-read-vector-function 'ioblock-no-char-input)
  (read-line-function 'ioblock-no-char-input)
  (write-char-when-locked-function 'ioblock-no-char-output)
  (read-byte-when-locked-function 'ioblock-no-binary-input)
  (write-byte-when-locked-function 'ioblock-no-binary-output)
  (peek-char-function 'ioblock-no-char-input)
  (native-byte-order t)
  (read-char-without-translation-when-locked-function 'ioblock-no-char-input)
  (write-char-without-translation-when-locked-function 'iblock-no-char-output)
  (sharing nil)
  (line-termination nil)
  (unread-char-function 'ioblock-no-char-input)
  (encode-literal-char-code-limit 256)
  (reserved3 nil))


;;; Functions on ioblocks.  So far, we aren't saying anything
;;; about how streams use them.

(defun ioblock-no-binary-input (ioblock &rest otters)
  (declare (ignore otters))
  (report-bad-arg (ioblock-stream ioblock) '(and binary-stream input-stream)))

(defun ioblock-no-binary-output (ioblock &rest others)
  (declare (ignore others))
  (report-bad-arg (ioblock-stream ioblock) '(and binary-stream output-stream)))

(defun ioblock-no-char-input (ioblock &rest others)
  (declare (ignore others))
  (report-bad-arg (ioblock-stream ioblock) '(and character-stream input-stream)))

(defun ioblock-no-char-output (ioblock &rest others)
  (declare (ignore others))
  (report-bad-arg (ioblock-stream ioblock) '(and character-stream output-stream)))


(defun ioblock-octets-to-elements (ioblock octets)
  (let* ((shift (ioblock-element-shift ioblock)))
    (declare (fixnum shift))
    (if (zerop shift)
      octets
      (ash octets (- shift)))))

(defun ioblock-elements-to-octets (ioblock elements)
  (let* ((shift (ioblock-element-shift ioblock)))
    (declare (fixnum shift))
    (if (zerop shift)
      elements
      (ash elements shift))))



;;; ioblock must really be an ioblock or you will crash
;;; Also: the expression "ioblock" is evaluated multiple times.

(declaim (inline check-ioblock-owner))
(defun check-ioblock-owner (ioblock)
  (declare (optimize (speed 3)))
  (let* ((owner (ioblock-owner ioblock)))
    (if owner
      (or (eq owner *current-process*)
          (error "Stream ~s is private to ~s" (ioblock-stream ioblock) owner)))))



(declaim (inline %ioblock-advance))
(defun %ioblock-advance (ioblock read-p)
  (funcall (ioblock-advance-function ioblock)
           (ioblock-stream ioblock)
           ioblock
           read-p))


(defun %ioblock-surrounding-characters (ioblock)
  (let* ((inbuf (ioblock-inbuf ioblock)))
    (when inbuf
      (let* ((encoding (or (ioblock-encoding ioblock)
                           (get-character-encoding nil)))
             (size (ash (character-encoding-code-unit-size encoding) -3))
             (buffer (io-buffer-buffer inbuf))
             (idx (io-buffer-idx inbuf))
             (count (io-buffer-count inbuf)))
        (unless (= count 0)
          (let* ((start (max (- idx (* 5 size)) 0))
                 (end (min (+ idx (* 5 size)) count))
                 (string (make-string (funcall (character-encoding-length-of-vector-encoding-function encoding) buffer start end))))
            (funcall (character-encoding-vector-decode-function encoding)
                     buffer
                     start
                     (- end start)
                     string)
            (if (position #\Replacement_Character string)
              (string-trim (string #\Replacement_Character) string)
              string)))))))
             
        


(defun %bivalent-ioblock-read-u8-byte (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (setf (ioblock-untyi-char ioblock) nil)
  (let* ((buf (ioblock-inbuf ioblock))
         (idx (io-buffer-idx buf))
         (limit (io-buffer-count buf)))
    (declare (fixnum idx limit))
    (when (= idx limit)
      (unless (%ioblock-advance ioblock t)
        (return-from %bivalent-ioblock-read-u8-byte :eof))
      (setq idx (io-buffer-idx buf)
            limit (io-buffer-count buf)))
    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
    (aref (the (simple-array (unsigned-byte 8) (*))
              (io-buffer-buffer buf)) idx)))


(declaim (inline %ioblock-read-u8-byte))
(defun %ioblock-read-u8-byte (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((buf (ioblock-inbuf ioblock))
         (idx (io-buffer-idx buf))
         (limit (io-buffer-count buf)))
    (declare (fixnum idx limit))
    (when (= idx limit)
      (unless (%ioblock-advance ioblock t)
        (return-from %ioblock-read-u8-byte :eof))
      (setq idx (io-buffer-idx buf)))
    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
    (aref (the (simple-array (unsigned-byte 8) (*))
            (io-buffer-buffer buf)) idx)))

(declaim (inline %ioblock-read-u8-code-unit))
(defun %ioblock-read-u8-code-unit (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((buf (ioblock-inbuf ioblock))
         (idx (io-buffer-idx buf))
         (limit (io-buffer-count buf)))
    (declare (fixnum idx limit))
    (when (= idx limit)
      (unless (%ioblock-advance ioblock t)
        (return-from %ioblock-read-u8-code-unit :eof))
      (setq idx (io-buffer-idx buf)
            limit (io-buffer-count buf)))
    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
    (aref (the (simple-array (unsigned-byte 8) (*))
              (io-buffer-buffer buf)) idx)))             

(declaim (inline %ioblock-read-s8-byte))
(defun %ioblock-read-s8-byte (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((buf (ioblock-inbuf ioblock))
         (idx (io-buffer-idx buf))
         (limit (io-buffer-count buf)))
    (declare (fixnum idx limit))
    (when (= idx limit)
      (unless (%ioblock-advance ioblock t)
        (return-from %ioblock-read-s8-byte :eof))
      (setq idx (io-buffer-idx buf)
            limit (io-buffer-count buf)))
    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
    (aref (the (simple-array (signed-byte 8) (*))
            (io-buffer-buffer buf)) idx)))

(defun %private-ioblock-read-s8-byte (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-read-s8-byte ioblock))

(defun %locked-ioblock-read-s8-byte (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-input-lock-grabbed (ioblock)
    (%ioblock-read-s8-byte ioblock)))


(declaim (inline %ioblock-read-u16-byte))
(defun %ioblock-read-u16-byte (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((buf (ioblock-inbuf ioblock))
         (idx (io-buffer-idx buf))
         (limit (io-buffer-count buf)))
    (declare (fixnum idx limit))
    (when (= idx limit)
      (unless (%ioblock-advance ioblock t)
        (return-from %ioblock-read-u16-byte :eof))
      (setq idx (io-buffer-idx buf)
            limit (io-buffer-count buf)))
    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
    (aref (the (simple-array (unsigned-byte 16) (*))
            (io-buffer-buffer buf)) idx)))

(defun %private-ioblock-read-u16-byte (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-read-u16-byte ioblock))

(defun %locked-ioblock-read-u16-byte (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-input-lock-grabbed (ioblock)
    (%ioblock-read-u16-byte ioblock)))

(declaim (inline %ioblock-read-s16-byte))
(defun %ioblock-read-s16-byte (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((buf (ioblock-inbuf ioblock))
         (idx (io-buffer-idx buf))
         (limit (io-buffer-count buf)))
    (declare (fixnum idx limit))
    (when (= idx limit)
      (unless (%ioblock-advance ioblock t)
        (return-from %ioblock-read-s16-byte :eof))
      (setq idx (io-buffer-idx buf)
            limit (io-buffer-count buf)))
    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
    (aref (the (simple-array (signed-byte 16) (*))
            (io-buffer-buffer buf)) idx)))

(defun %private-ioblock-read-s16-byte (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-read-s16-byte ioblock))

(defun %locked-ioblock-read-s16-byte (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-input-lock-grabbed (ioblock)
    (%ioblock-read-s16-byte ioblock)))


(declaim (inline %ioblock-read-u32-byte))
(defun %ioblock-read-u32-byte (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((buf (ioblock-inbuf ioblock))
         (idx (io-buffer-idx buf))
         (limit (io-buffer-count buf)))
    (declare (fixnum idx limit))
    (when (= idx limit)
      (unless (%ioblock-advance ioblock t)
        (return-from %ioblock-read-u32-byte :eof))
      (setq idx (io-buffer-idx buf)
            limit (io-buffer-count buf)))
    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
    (aref (the (simple-array (unsigned-byte 32) (*))
            (io-buffer-buffer buf)) idx)))

(defun %private-ioblock-read-u32-byte (ioblock)
  (check-ioblock-owner ioblock)
  (%ioblock-read-u32-byte ioblock))

(defun %locked-ioblock-read-u32-byte (ioblock)
  (with-ioblock-input-lock-grabbed (ioblock)
    (%ioblock-read-u32-byte ioblock)))

(declaim (inline %ioblock-read-s32-byte))
(defun %ioblock-read-s32-byte (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((buf (ioblock-inbuf ioblock))
         (idx (io-buffer-idx buf))
         (limit (io-buffer-count buf)))
    (declare (fixnum idx limit))
    (when (= idx limit)
      (unless (%ioblock-advance ioblock t)
        (return-from %ioblock-read-s32-byte :eof))
      (setq idx (io-buffer-idx buf)
            limit (io-buffer-count buf)))
    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
    (aref (the (simple-array (signed-byte 32) (*))
            (io-buffer-buffer buf)) idx)))

(defun %private-ioblock-read-s32-byte (ioblock)
  (check-ioblock-owner ioblock)
  (%ioblock-read-s32-byte ioblock))

(defun %locked-ioblock-read-s32-byte (ioblock)
  (with-ioblock-input-lock-grabbed (ioblock)
    (%ioblock-read-s32-byte ioblock)))

#+64-bit-target
(progn
(declaim (inline %ioblock-read-u64-byte))
(defun %ioblock-read-u64-byte (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((buf (ioblock-inbuf ioblock))
         (idx (io-buffer-idx buf))
         (limit (io-buffer-count buf)))
    (declare (fixnum idx limit))
    (when (= idx limit)
      (unless (%ioblock-advance ioblock t)
        (return-from %ioblock-read-u64-byte :eof))
      (setq idx (io-buffer-idx buf)
            limit (io-buffer-count buf)))
    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
    (aref (the (simple-array (unsigned-byte 64) (*))
            (io-buffer-buffer buf)) idx)))

(defun %private-ioblock-read-u64-byte (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-read-u64-byte ioblock))

(defun %locked-ioblock-read-u64-byte (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-input-lock-grabbed (ioblock)
    (%ioblock-read-u64-byte ioblock)))

(defun %ioblock-read-s64-byte (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((buf (ioblock-inbuf ioblock))
         (idx (io-buffer-idx buf))
         (limit (io-buffer-count buf)))
    (declare (fixnum idx limit))
    (when (= idx limit)
      (unless (%ioblock-advance ioblock t)
        (return-from %ioblock-read-s64-byte :eof))
      (setq idx (io-buffer-idx buf)
            limit (io-buffer-count buf)))
    (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
    (aref (the (simple-array (signed-byte 64) (*))
            (io-buffer-buffer buf)) idx)))

(defun %private-ioblock-read-s64-byte (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-read-s64-byte ioblock))

(defun %locked-ioblock-read-s64-byte (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-input-lock-grabbed (ioblock)
    (%ioblock-read-s64-byte ioblock)))
)


;;; Read a 16-bit code element from a stream with element-type
;;; (UNSIGNED-BYTE 8), in native byte-order.

(declaim (inline %ioblock-read-u16-code-unit))
(defun %ioblock-read-u16-code-unit (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((buf (ioblock-inbuf ioblock))
         (idx (io-buffer-idx buf))
         (limit (io-buffer-count buf))
         (vector (io-buffer-buffer buf)))
    (declare (fixnum idx limit)
             (type (simple-array (unsigned-byte 8) (*)) vector))
    (if (<= (the fixnum (+ idx 2)) limit)
      (let* ((b0 (aref vector idx))
             (b1 (aref vector (the fixnum (1+ idx)))))
        (declare (type (unsigned-byte 8) b0 b1))
        (setf (io-buffer-idx buf) (the fixnum (+ idx 2)))
        #+big-endian-target
        (logior (the (unsigned-byte 16) (ash b0 8)) b1)
        #+little-endian-target
        (logior (the (unsigned-byte 16) (ash b1 8)) b0))
      (if (< idx limit)
        (let* ((b0 (aref vector idx))
               (n (%ioblock-advance ioblock t)))
          (declare (type (unsigned-byte 8) b0))
          (if (null n)
            :eof
            (let* ((b1 (aref vector 0)))
              (declare (type (unsigned-byte 8) b1))
              (setf (io-buffer-idx buf) 1)
              #+big-endian-target
              (logior (the (unsigned-byte 16) (ash b0 8)) b1)
              #+little-endian-target
              (logior (the (unsigned-byte 16) (ash b1 8)) b0))))
        (let* ((n (%ioblock-advance ioblock t)))
          (if (null n)
            :eof
            (if (eql n 1)
              (progn
                (setf (io-buffer-idx buf) 1)
                :eof)
              (let* ((b0 (aref vector 0))
                     (b1 (aref vector 1)))
                (declare (type (unsigned-byte 8) b0 b1))
                (setf (io-buffer-idx buf) 2)
                #+big-endian-target
                (logior (the (unsigned-byte 16) (ash b0 8)) b1)
                #+little-endian-target
                (logior (the (unsigned-byte 16) (ash b1 8)) b0)))))))))
  
(declaim (inline %ioblock-read-swapped-u16-code-unit))
(defun %ioblock-read-swapped-u16-code-unit (ioblock)
  (declare (optimize (speed 3) (safety 0)))
    (let* ((buf (ioblock-inbuf ioblock))
         (idx (io-buffer-idx buf))
         (limit (io-buffer-count buf))
         (vector (io-buffer-buffer buf)))
    (declare (fixnum idx limit)
             (type (simple-array (unsigned-byte 8) (*)) vector))
    (if (<= (the fixnum (+ idx 2)) limit)
      (let* ((b0 (aref vector idx))
             (b1 (aref vector (the fixnum (1+ idx)))))
        (declare (type (unsigned-byte 8) b0 b1))
        (setf (io-buffer-idx buf) (the fixnum (+ idx 2)))
        #+little-endian-target
        (logior (the (unsigned-byte 16) (ash b0 8)) b1)
        #+big-endian-target
        (logior (the (unsigned-byte 16) (ash b1 8)) b0))
      (if (< idx limit)
        (let* ((b0 (aref vector idx))
               (n (%ioblock-advance ioblock t)))
          (declare (type (unsigned-byte 8) b0))
          (if (null n)
            :eof
            (let* ((b1 (aref vector 0)))
              (declare (type (unsigned-byte 8) b1))
              (setf (io-buffer-idx buf) 1)
              #+little-endian-target
              (logior (the (unsigned-byte 16) (ash b0 8)) b1)
              #+big-endian-target
              (logior (the (unsigned-byte 16) (ash b1 8)) b0))))
        (let* ((n (%ioblock-advance ioblock t)))
          (if (null n)
            :eof
            (if (eql n 1)
              (progn
                (setf (io-buffer-idx buf) 1)
                :eof)
              (let* ((b0 (aref vector 0))
                     (b1 (aref vector 1)))
                (declare (type (unsigned-byte 8) b0 b1))
                (setf (io-buffer-idx buf) 2)
                #+little-endian-target
                (logior (the (unsigned-byte 16) (ash b0 8)) b1)
                #+big-endian-target
                (logior (the (unsigned-byte 16) (ash b1 8)) b0)))))))))


(declaim (inline %ioblock-read-u32-code-unit))
(defun %ioblock-read-u32-code-unit (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((buf (ioblock-inbuf ioblock))
         (idx (io-buffer-idx buf))
         (limit (io-buffer-count buf))
         (vector (io-buffer-buffer buf)))
    (declare (fixnum idx limit)
             (type (simple-array (unsigned-byte 8) (*)) vector))
    (cond ((<= (the fixnum (+ idx 4)) limit)
           (let* ((b0 (aref vector idx))
                  (b1 (aref vector (the fixnum (1+ idx))))
                  (b2 (aref vector (the fixnum (+ idx 2))))
                  (b3 (aref vector (the fixnum (+ idx 3)))))
             (declare (type (unsigned-byte 8) b0 b1 b2 b3))
             (setf (io-buffer-idx buf) (the fixnum (+ idx 4)))
             #+big-endian-target
             (logior (the (unsigned-byte 32) (ash b0 24))
                     (the (unsigned-byte 24) (ash b1 16))
                     (the (unsigned-byte 16) (ash b2 8))
                     b3)
             #+little-endian-target
             (logior (the (unsigned-byte 32) (ash b3 24))
                     (the (unsigned-byte 24) (ash b2 16))
                     (the (unsigned-byte 16) (ash b1 8))
                     b0)))
          ((= (the fixnum (+ idx 3)) limit)
           (let* ((b0 (aref vector idx))
                  (b1 (aref vector (the fixnum (1+ idx))))
                  (b2 (aref vector (the fixnum (+ idx 2))))
                  (n (%ioblock-advance ioblock t)))
             (declare (type (unsigned-byte 8) b0 b1 b2))
             (if (null n)
               :eof
               (let* ((b3 (aref vector 0)))
                 (declare (type (unsigned-byte 8) b3))
                 (setf (io-buffer-idx buf) 1)
                 #+big-endian-target
                 (logior (the (unsigned-byte 32) (ash b0 24))
                         (the (unsigned-byte 24) (ash b1 16))
                         (the (unsigned-byte 16) (ash b2 8))
                         b3)
                 #+little-endian-target
                 (logior (the (unsigned-byte 32) (ash b3 24))
                         (the (unsigned-byte 24) (ash b2 16))
                         (the (unsigned-byte 16) (ash b1 8))
                         b0)))))
          ((= (the fixnum (+ idx 2)) limit)
           (let* ((b0 (aref vector idx))
                  (b1 (aref vector (the fixnum (1+ idx))))
                  (n (%ioblock-advance ioblock t)))
             (declare (type (unsigned-byte 8) b0 b1))
             (if (null n)
               :eof
               (if (eql n 1)
                 (progn
                   (setf (io-buffer-idx buf) 1)
                   :eof)
                 (let* ((b2 (aref vector 0))
                        (b3 (aref vector 1)))
                   (declare (type (unsigned-byte 8) b2 b3))
                   (setf (io-buffer-idx buf) 2)
                   #+big-endian-target
                   (logior (the (unsigned-byte 32) (ash b0 24))
                           (the (unsigned-byte 24) (ash b1 16))
                           (the (unsigned-byte 16) (ash b2 8))
                           b3)
                   #+little-endian-target
                   (logior (the (unsigned-byte 32) (ash b3 24))
                           (the (unsigned-byte 24) (ash b2 16))
                           (the (unsigned-byte 16) (ash b1 8))
                           b0))))))
          ((= (the fixnum (1+ idx)) limit)
           (let* ((b0 (aref vector idx))
                  (n (%ioblock-advance ioblock t)))
             (declare (type (unsigned-byte 8) b0))
             (if (null n)
               :eof
               (if (< n 3)
                 (progn
                   (setf (io-buffer-idx buf) n)
                   :eof)
                 (let* ((b1 (aref vector 0))
                        (b2 (aref vector 1))
                        (b3 (aref vector 2)))
                   (setf (io-buffer-idx buf) 3)
                   #+big-endian-target
                   (logior (the (unsigned-byte 32) (ash b0 24))
                           (the (unsigned-byte 24) (ash b1 16))
                           (the (unsigned-byte 16) (ash b2 8))
                           b3)
                   #+little-endian-target
                   (logior (the (unsigned-byte 32) (ash b3 24))
                           (the (unsigned-byte 24) (ash b2 16))
                           (the (unsigned-byte 16) (ash b1 8))
                           b0))))))
          (t
           (let* ((n (%ioblock-advance ioblock t)))
             (if (null n)
               :eof
               (if (< n 4)
                 (progn
                   (setf (io-buffer-idx buf) n)
                   :eof)
                 (let* ((b0 (aref vector 0))
                        (b1 (aref vector 1))
                        (b2 (aref vector 2))
                        (b3 (aref vector 3)))
                (declare (type (unsigned-byte 8) b0 b1 b2 b3))
                (setf (io-buffer-idx buf) 4)
                #+big-endian-target
                (logior (the (unsigned-byte 32) (ash b0 24))
                        (the (unsigned-byte 24) (ash b1 16))
                        (the (unsigned-byte 16) (ash b2 8))
                        b3)
                #+little-endian-target
                (logior (the (unsigned-byte 32) (ash b3 24))
                        (the (unsigned-byte 24) (ash b2 16))
                        (the (unsigned-byte 16) (ash b1 8))
                        b0)))))))))

(declaim (inline %ioblock-read-swapped-u32-code-unit))
(defun %ioblock-read-swapped-u32-code-unit (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((buf (ioblock-inbuf ioblock))
         (idx (io-buffer-idx buf))
         (limit (io-buffer-count buf))
         (vector (io-buffer-buffer buf)))
    (declare (fixnum idx limit)
             (type (simple-array (unsigned-byte 8) (*)) vector))
    (cond ((<= (the fixnum (+ idx 4)) limit)
           (let* ((b0 (aref vector idx))
                  (b1 (aref vector (the fixnum (1+ idx))))
                  (b2 (aref vector (the fixnum (+ idx 2))))
                  (b3 (aref vector (the fixnum (+ idx 3)))))
             (declare (type (unsigned-byte 8) b0 b1 b2 b3))
             (setf (io-buffer-idx buf) (the fixnum (+ idx 4)))
             #+little-endian-target
             (logior (the (unsigned-byte 32) (ash b0 24))
                     (the (unsigned-byte 24) (ash b1 16))
                     (the (unsigned-byte 16) (ash b2 8))
                     b3)
             #+big-endian-target
             (logior (the (unsigned-byte 32) (ash b3 24))
                     (the (unsigned-byte 24) (ash b2 16))
                     (the (unsigned-byte 16) (ash b1 8))
                     b0)))
          ((= (the fixnum (+ idx 3)) limit)
           (let* ((b0 (aref vector idx))
                  (b1 (aref vector (the fixnum (1+ idx))))
                  (b2 (aref vector (the fixnum (+ idx 2))))
                  (n (%ioblock-advance ioblock t)))
             (declare (type (unsigned-byte 8) b0 b1 b2))
             (if (null n)
               :eof
               (let* ((b3 (aref vector 0)))
                 (declare (type (unsigned-byte 8) b3))
                 (setf (io-buffer-idx buf) 1)
                 #+little-endian-target
                 (logior (the (unsigned-byte 32) (ash b0 24))
                         (the (unsigned-byte 24) (ash b1 16))
                         (the (unsigned-byte 16) (ash b2 8))
                         b3)
                 #+big-endian-target
                 (logior (the (unsigned-byte 32) (ash b3 24))
                         (the (unsigned-byte 24) (ash b2 16))
                         (the (unsigned-byte 16) (ash b1 8))
                         b0)))))
          ((= (the fixnum (+ idx 2)) limit)
           (let* ((b0 (aref vector idx))
                  (b1 (aref vector (the fixnum (1+ idx))))
                  (n (%ioblock-advance ioblock t)))
             (declare (type (unsigned-byte 8) b0 b1))
             (if (null n)
               :eof
               (if (eql n 1)
                 (progn
                   (setf (io-buffer-idx buf) 1)
                   :eof)
                 (let* ((b2 (aref vector 0))
                        (b3 (aref vector 1)))
                   (declare (type (unsigned-byte 8) b2 b3))
                   (setf (io-buffer-idx buf) 2)
                   #+little-endian-target
                   (logior (the (unsigned-byte 32) (ash b0 24))
                           (the (unsigned-byte 24) (ash b1 16))
                           (the (unsigned-byte 16) (ash b2 8))
                           b3)
                   #+big-endian-target
                   (logior (the (unsigned-byte 32) (ash b3 24))
                           (the (unsigned-byte 24) (ash b2 16))
                           (the (unsigned-byte 16) (ash b1 8))
                           b0))))))
          ((= (the fixnum (1+ idx)) limit)
           (let* ((b0 (aref vector idx))
                  (n (%ioblock-advance ioblock t)))
             (declare (type (unsigned-byte 8) b0))
             (if (null n)
               :eof
               (if (< n 3)
                 (progn
                   (setf (io-buffer-idx buf) n)
                   :eof)
                 (let* ((b1 (aref vector 0))
                        (b2 (aref vector 1))
                        (b3 (aref vector 2)))
                   (setf (io-buffer-idx buf) 3)
                   #+little-endian-target
                   (logior (the (unsigned-byte 32) (ash b0 24))
                           (the (unsigned-byte 24) (ash b1 16))
                           (the (unsigned-byte 16) (ash b2 8))
                           b3)
                   #+big-endian-target
                   (logior (the (unsigned-byte 32) (ash b3 24))
                           (the (unsigned-byte 24) (ash b2 16))
                           (the (unsigned-byte 16) (ash b1 8))
                           b0))))))
          (t
           (let* ((n (%ioblock-advance ioblock t)))
             (if (null n)
               :eof
               (if (< n 4)
                 (progn
                   (setf (io-buffer-idx buf) n)
                   :eof)
                 (let* ((b0 (aref vector 0))
                        (b1 (aref vector 1))
                        (b2 (aref vector 2))
                        (b3 (aref vector 3)))
                (declare (type (unsigned-byte 8) b0 b1 b2 b3))
                (setf (io-buffer-idx buf) 4)
                #+little-endian-target
                (logior (the (unsigned-byte 32) (ash b0 24))
                        (the (unsigned-byte 24) (ash b1 16))
                        (the (unsigned-byte 16) (ash b2 8))
                        b3)
                #+big-endian-target
                (logior (the (unsigned-byte 32) (ash b3 24))
                        (the (unsigned-byte 24) (ash b2 16))
                        (the (unsigned-byte 16) (ash b1 8))
                        b0)))))))))


(defun %bivalent-private-ioblock-read-u8-byte (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (setf (ioblock-untyi-char ioblock) nil)
    (let* ((buf (ioblock-inbuf ioblock))
           (idx (io-buffer-idx buf))
           (limit (io-buffer-count buf)))
      (declare (fixnum idx limit))
      (when (= idx limit)
        (unless (%ioblock-advance ioblock t)
          (return-from %bivalent-private-ioblock-read-u8-byte :eof))
        (setq idx (io-buffer-idx buf)
              limit (io-buffer-count buf)))
      (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
      (aref (the (simple-array (unsigned-byte 8) (*))
              (io-buffer-buffer buf)) idx)))

(defun %private-ioblock-read-u8-byte (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-read-u8-byte ioblock))

(defun %bivalent-locked-ioblock-read-u8-byte (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-input-lock-grabbed (ioblock)
    (setf (ioblock-untyi-char ioblock) nil)
    (let* ((buf (ioblock-inbuf ioblock))
           (idx (io-buffer-idx buf))
           (limit (io-buffer-count buf)))
      (declare (fixnum idx limit))
      (when (= idx limit)
        (unless (%ioblock-advance ioblock t)
          (return-from %bivalent-locked-ioblock-read-u8-byte :eof))
        (setq idx (io-buffer-idx buf)
              limit (io-buffer-count buf)))
      (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
      (aref (the (simple-array (unsigned-byte 8) (*))
              (io-buffer-buffer buf)) idx))))

(defun %locked-ioblock-read-u8-byte (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-input-lock-grabbed (ioblock)
    (%ioblock-read-u8-byte ioblock)))

(defun %general-ioblock-read-byte (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-input-locked (ioblock)
    (let* ((buf (ioblock-inbuf ioblock))
           (idx (io-buffer-idx buf))
           (limit (io-buffer-count buf)))
      (declare (fixnum idx limit))
      (when (= idx limit)
        (unless (%ioblock-advance ioblock t)
          (return-from %general-ioblock-read-byte :eof))
        (setq idx (io-buffer-idx buf)
              limit (io-buffer-count buf)))
      (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
      (uvref (io-buffer-buffer buf) idx))))


(declaim (inline %ioblock-tyi))
(defun %ioblock-tyi (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((ch (ioblock-untyi-char ioblock)))
    (if ch
      (prog1 ch
        (setf (ioblock-untyi-char ioblock) nil))
      (let* ((buf (ioblock-inbuf ioblock))
             (idx (io-buffer-idx buf))
             (limit (io-buffer-count buf)))
        (declare (fixnum idx limit))
        (when (= idx limit)
          (unless (%ioblock-advance ioblock t)
            (return-from %ioblock-tyi :eof))
          (setq idx 0))
        (setf (io-buffer-idx buf) (the fixnum (1+ idx)))
        (%code-char (aref (the (simple-array (unsigned-byte 8) (*))
                                       (io-buffer-buffer buf)) idx))))))

(defun %private-ioblock-tyi (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-tyi ioblock))

(defun %locked-ioblock-tyi (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-input-lock-grabbed (ioblock)
    (%ioblock-tyi ioblock)))

;;; Read a character composed of one or more 8-bit code-units.
(declaim (inline %ioblock-read-u8-encoded-char))
(defun %ioblock-read-u8-encoded-char (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((ch (ioblock-untyi-char ioblock)))
    (if ch
      (prog1 ch
        (setf (ioblock-untyi-char ioblock) nil))
      (let* ((1st-unit (%ioblock-read-u8-code-unit ioblock)))
        (if (eq 1st-unit :eof)
          1st-unit
          (locally
              (declare (type (unsigned-byte 8) 1st-unit))
            (if (< 1st-unit
                   (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock)))
              (%code-char 1st-unit)
              (funcall (ioblock-decode-input-function ioblock)
                       1st-unit
                       #'%ioblock-read-u8-code-unit
                       ioblock))))))))

(defun %private-ioblock-read-u8-encoded-char (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-read-u8-encoded-char ioblock))

(defun %locked-ioblock-read-u8-encoded-char (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-input-lock-grabbed (ioblock)
    (%ioblock-read-u8-encoded-char ioblock)))

(declaim (inline %ioblock-read-u16-encoded-char))
(defun %ioblock-read-u16-encoded-char (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((ch (ioblock-untyi-char ioblock)))
    (if ch
      (prog1 ch
        (setf (ioblock-untyi-char ioblock) nil))
      (let* ((1st-unit (%ioblock-read-u16-code-unit ioblock)))
        (if (eq 1st-unit :eof)
          1st-unit
          (locally
              (declare (type (unsigned-byte 16) 1st-unit))
            (if (< 1st-unit
                   (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock)))
              (code-char 1st-unit)
              (funcall (ioblock-decode-input-function ioblock)
                       1st-unit
                       #'%ioblock-read-u16-code-unit
                       ioblock))))))))

(defun %private-ioblock-read-u16-encoded-char (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-read-u16-encoded-char ioblock))

(defun %locked-ioblock-read-u16-encoded-char (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-input-lock-grabbed (ioblock)
    (%ioblock-read-u16-encoded-char ioblock)))

(declaim (inline %ioblock-read-swapped-u16-encoded-char))
(defun %ioblock-read-swapped-u16-encoded-char (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((ch (ioblock-untyi-char ioblock)))
    (if ch
      (prog1 ch
        (setf (ioblock-untyi-char ioblock) nil))
      (let* ((1st-unit (%ioblock-read-swapped-u16-code-unit ioblock)))
        (if (eq 1st-unit :eof)
          1st-unit
          (locally
              (declare (type (unsigned-byte 16) 1st-unit))
            (if (< 1st-unit
                   (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock)))
              (code-char 1st-unit)
              (funcall (ioblock-decode-input-function ioblock)
                       1st-unit
                       #'%ioblock-read-swapped-u16-code-unit
                       ioblock))))))))

(defun %private-ioblock-read-swapped-u16-encoded-char (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-read-swapped-u16-encoded-char ioblock))

(defun %locked-ioblock-read-swapped-u16-encoded-char (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-input-lock-grabbed (ioblock)
    (%ioblock-read-swapped-u16-encoded-char ioblock)))

(declaim (inline %ioblock-read-u32-encoded-char))
(defun %ioblock-read-u32-encoded-char (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((ch (ioblock-untyi-char ioblock)))
    (if ch
      (prog1 ch
        (setf (ioblock-untyi-char ioblock) nil))
      (let* ((1st-unit (%ioblock-read-u32-code-unit ioblock)))
        (if (eq 1st-unit :eof)
          1st-unit
          (locally
              (declare (type (unsigned-byte 16) 1st-unit))
            (if (< 1st-unit
                   (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock)))
              (code-char 1st-unit)
              (funcall (ioblock-decode-input-function ioblock)
                       1st-unit
                       #'%ioblock-read-u32-code-unit
                       ioblock))))))))

(defun %private-ioblock-read-u32-encoded-char (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-read-u32-encoded-char ioblock))

(defun %locked-ioblock-read-u32-encoded-char (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-input-lock-grabbed (ioblock)
    (%ioblock-read-u32-encoded-char ioblock)))

(declaim (inline %ioblock-read-swapped-u32-encoded-char))
(defun %ioblock-read-swapped-u32-encoded-char (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((ch (ioblock-untyi-char ioblock)))
    (if ch
      (prog1 ch
        (setf (ioblock-untyi-char ioblock) nil))
      (let* ((1st-unit (%ioblock-read-swapped-u32-code-unit ioblock)))
        (if (eq 1st-unit :eof)
          1st-unit
          (locally
              (declare (type (unsigned-byte 16) 1st-unit))
            (if (< 1st-unit
                   (the (mod #x110000) (ioblock-decode-literal-code-unit-limit ioblock)))
              (code-char 1st-unit)
              (funcall (ioblock-decode-input-function ioblock)
                       1st-unit
                       #'%ioblock-read-swapped-u32-code-unit
                       ioblock))))))))

(defun %private-ioblock-read-swapped-u32-encoded-char (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-read-swapped-u32-encoded-char ioblock))

(defun %locked-ioblock-read-swapped-u32-encoded-char (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-input-lock-grabbed (ioblock)
    (%ioblock-read-swapped-u32-encoded-char ioblock)))

(declaim (inline %ioblock-tyi-no-hang))
(defun %ioblock-tyi-no-hang (ioblock)
  (declare (optimize (speed 3) (safety 0)))
  (if (ioblock-untyi-char ioblock)
    (prog1 (ioblock-untyi-char ioblock)
      (setf (ioblock-untyi-char ioblock) nil))
    (let* ((buf (ioblock-inbuf ioblock))
           (idx (io-buffer-idx buf))
           (limit (io-buffer-count buf)))
      (declare (fixnum idx limit))
      (when (= idx limit)
        (unless (%ioblock-advance ioblock nil)
          (return-from %ioblock-tyi-no-hang (if (ioblock-eof ioblock) :eof))))
      (funcall (ioblock-read-char-when-locked-function ioblock) ioblock))))

;;; :iso-8859-1 only.
(defun %ioblock-peek-char (ioblock)
  (or (ioblock-untyi-char ioblock)
      (let* ((buf (ioblock-inbuf ioblock))
             (idx (io-buffer-idx buf))
             (limit (io-buffer-count buf)))
        (declare (fixnum idx limit))
        (when (= idx limit)
          (unless (%ioblock-advance ioblock t)
            (return-from %ioblock-peek-char :eof))
          (setq idx (io-buffer-idx buf)
                limit (io-buffer-count buf)))
        (%code-char (aref (the (simple-array (unsigned-byte 8) (*)) (io-buffer-buffer buf)) idx)))))

(defun %encoded-ioblock-peek-char (ioblock)
  (or (ioblock-untyi-char ioblock)
      (let* ((ch (funcall (ioblock-read-char-when-locked-function ioblock) ioblock)))
        (unless (eq ch :eof)
          (setf (ioblock-untyi-char ioblock) ch))
        ch)))




(defun %ioblock-clear-input (ioblock)    
    (let* ((buf (ioblock-inbuf ioblock)))
      (setf (io-buffer-count buf) 0
            (io-buffer-idx buf) 0
            (ioblock-untyi-char ioblock) nil)))

(defun %ioblock-untyi (ioblock char)
  (if (ioblock-untyi-char ioblock)
    (error "Two UNREAD-CHARs without intervening READ-CHAR on ~s"
           (ioblock-stream ioblock))
    (setf (ioblock-untyi-char ioblock) char)))

(declaim (inline ioblock-inpos))

(defun ioblock-inpos (ioblock)
  (io-buffer-idx (ioblock-inbuf ioblock)))

(declaim (inline ioblock-outpos))

(defun ioblock-outpos (ioblock)
  (io-buffer-count (ioblock-outbuf ioblock)))



(declaim (inline %ioblock-force-output))

(defun %ioblock-force-output (ioblock finish-p)
  (funcall (ioblock-force-output-function ioblock)
           (ioblock-stream ioblock)
           ioblock
           (ioblock-outpos ioblock)
           finish-p))

;;; ivector should be an ivector.  The ioblock should have an
;;; element-shift of 0; start-octet and num-octets should of course
;;; be sane.  This is mostly to give the fasdumper a quick way to
;;; write immediate data.
(defun %ioblock-out-ivect (ioblock ivector start-octet num-octets)
  (unless (= 0 (the fixnum (ioblock-element-shift ioblock)))
    (error "Can't write vector to stream ~s" (ioblock-stream ioblock)))
  (let* ((written 0)
         (out (ioblock-outbuf ioblock))
         (bufsize (io-buffer-size out))
         (buffer (io-buffer-buffer out)))
    (declare (fixnum written bufsize))
    (do* ((pos start-octet (+ pos written))
          (left num-octets (- left written)))
         ((= left 0) num-octets)
      (declare (fixnum pos left))
      (setf (ioblock-dirty ioblock) t)
      (let* ((index (io-buffer-idx out))
             (count (io-buffer-count out))
             (avail (- bufsize index)))
        (declare (fixnum index avail count))
        (cond
          ((= (setq written avail) 0)
           (%ioblock-force-output ioblock nil))
          (t
           (if (> written left)
             (setq written left))
           (%copy-ivector-to-ivector ivector pos buffer index written)
           (setf (ioblock-dirty ioblock) t)
           (incf index written)
           (if (> index count)
             (setf (io-buffer-count out) index))
           (setf (io-buffer-idx out) index)
           (if (= index  bufsize)
             (%ioblock-force-output ioblock nil))))))))


(defun %ioblock-unencoded-write-simple-string (ioblock string start-char num-chars)
  (declare (fixnum start-char num-chars) (simple-string string))
  (let* ((written 0)
         (col (ioblock-charpos ioblock))
         (out (ioblock-outbuf ioblock))
         (bufsize (io-buffer-size out))
         (buffer (io-buffer-buffer out)))
    (declare (fixnum written bufsize col)
             (type (simple-array (unsigned-byte 8) (*)) buffer)
             (optimize (speed 3) (safety 0)))
    (do* ((pos start-char (+ pos written))
          (left num-chars (- left written)))
         ((= left 0) (setf (ioblock-charpos ioblock) col)  num-chars)
      (declare (fixnum pos left))
      (setf (ioblock-dirty ioblock) t)
      (let* ((index (io-buffer-idx out))
             (count (io-buffer-count out))
             (avail (- bufsize index)))
        (declare (fixnum index avail count))
        (cond
          ((= (setq written avail) 0)
           (%ioblock-force-output ioblock nil))
          (t
           (if (> written left)
             (setq written left))
           (do* ((p pos (1+ p))
                 (i index (1+ i))
                 (j 0 (1+ j)))
                ((= j written))
             (declare (fixnum p i j))
             (let* ((ch (schar string p))
                    (code (char-code ch)))
               (declare (type (mod #x110000) code))
               (if (eql ch #\newline)
                 (setq col 0)
                 (incf col))
               (setf (aref buffer i) (if (>= code 256) (char-code #\Sub) code))))
           (setf (ioblock-dirty ioblock) t)
           (incf index written)
           (if (> index count)
             (setf (io-buffer-count out) index))
           (setf (io-buffer-idx out) index)
           (if (= index  bufsize)
             (%ioblock-force-output ioblock nil))))))))



(defun %ioblock-eofp (ioblock)
  (let* ((buf (ioblock-inbuf ioblock)))
   (and (eql (io-buffer-idx buf)
             (io-buffer-count buf))
         (locally (declare (optimize (speed 3) (safety 0)))
           (with-ioblock-input-locked (ioblock)
             (funcall (ioblock-eofp-function ioblock)
                      (ioblock-stream ioblock)
                      ioblock))))))

(defun %ioblock-listen (ioblock)
  (let* ((buf (ioblock-inbuf ioblock)))
    (or (< (the fixnum (io-buffer-idx buf))
           (the fixnum (io-buffer-count buf)))
        (funcall (ioblock-listen-function ioblock)
                 (ioblock-stream ioblock)
                 ioblock))))

(declaim (inline %ioblock-write-element))

(defun %ioblock-write-element (ioblock element)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((buf (ioblock-outbuf ioblock))
         (idx (io-buffer-idx buf))
         (count (io-buffer-count buf))
         (limit (io-buffer-limit buf)))
    (declare (fixnum idx limit count))
    (when (= idx limit)
      (%ioblock-force-output ioblock nil)
      (setq idx 0 count 0))
    (setf (aref (io-buffer-buffer buf) idx) element)
    (incf idx)
    (setf (io-buffer-idx buf) idx)
    (when (> idx count)
      (setf (io-buffer-count buf) idx))
    (setf (ioblock-dirty ioblock) t)
    element))

(declaim (inline %ioblock-write-u8-element))
(defun %ioblock-write-u8-element (ioblock element)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((buf (ioblock-outbuf ioblock))
         (idx (io-buffer-idx buf))
         (count (io-buffer-count buf))
         (limit (io-buffer-limit buf)))
    (declare (fixnum idx limit count))
    (when (= idx limit)
      (%ioblock-force-output ioblock nil)
      (setq idx 0 count 0))
    (setf (aref (the (simple-array (unsigned-byte 8) (*)) (io-buffer-buffer buf)) idx) element)
    (incf idx)
    (setf (io-buffer-idx buf) idx)
    (when (> idx count)
      (setf (io-buffer-count buf) idx))
    (setf (ioblock-dirty ioblock) t)
    element))

(declaim (inline %ioblock-write-s8-element))
(defun %ioblock-write-s8-element (ioblock element)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((buf (ioblock-outbuf ioblock))
         (idx (io-buffer-idx buf))
         (count (io-buffer-count buf))
         (limit (io-buffer-limit buf)))
    (declare (fixnum idx limit count))
    (when (= idx limit)
      (%ioblock-force-output ioblock nil)
      (setq idx 0 count 0))
    (setf (aref (the (simple-array (signed-byte 8) (*)) (io-buffer-buffer buf)) idx) element)
    (incf idx)
    (setf (io-buffer-idx buf) idx)
    (when (> idx count)
      (setf (io-buffer-count buf) idx))
    (setf (ioblock-dirty ioblock) t)
    element))

(declaim (inline %ioblock-write-u16-element))
(defun %ioblock-write-u16-element (ioblock element)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((buf (ioblock-outbuf ioblock))
         (idx (io-buffer-idx buf))
         (count (io-buffer-count buf))
         (limit (io-buffer-limit buf)))
    (declare (fixnum idx limit count))
    (when (= idx limit)
      (%ioblock-force-output ioblock nil)
      (setq idx 0 count 0))
    (setf (aref (the (simple-array (unsigned-byte 16) (*)) (io-buffer-buffer buf)) idx) element)
    (incf idx)
    (setf (io-buffer-idx buf) idx)
    (when (> idx count)
      (setf (io-buffer-count buf) idx))
    (setf (ioblock-dirty ioblock) t)
    element))

(declaim (inline %ioblock-write-u16-code-unit))
(defun %ioblock-write-u16-code-unit (ioblock element)
  (declare (optimize (speed 3) (safety 0))
           (type (unsigned-byte 16) element))
  (let* ((buf (ioblock-outbuf ioblock))
         (idx (io-buffer-idx buf))
         (count (io-buffer-count buf))
         (limit (io-buffer-limit buf))
         (vector (io-buffer-buffer buf))
         (b0 #+big-endian-target (ldb (byte 8 8) element)
             #+little-endian-target (ldb (byte 8 0) element))
         (b1 #+big-endian-target (ldb (byte 8 0) element)
             #+little-endian-target (ldb (byte 8 8) element)))
    (declare (fixnum idx limit count)
             (type (simple-array (unsigned-byte 8) (*)) vector)
             (type (unsigned-byte 8) b0 b1))
   
    (when (= idx limit)
      (%ioblock-force-output ioblock nil)
      (setq idx 0 count 0))
    (setf (aref vector idx) b0)
    (incf idx)
    (when (= idx limit)
      (when (> idx count)
        (setf (io-buffer-count buf) idx))
      (%ioblock-force-output ioblock nil)
      (setq idx 0 count 0))
    (setf (aref vector idx) b1)
    (incf idx)
    (setf (io-buffer-idx buf) idx)
    (when (> idx count)
      (setf (io-buffer-count buf) idx))
    (setf (ioblock-dirty ioblock) t)
    element))

(declaim (inline %ioblock-write-swapped-u16-code-unit))
(defun %ioblock-write-swapped-u16-code-unit (ioblock element)
  (declare (optimize (speed 3) (safety 0)))
(let* ((buf (ioblock-outbuf ioblock))
         (idx (io-buffer-idx buf))
         (count (io-buffer-count buf))
         (limit (io-buffer-limit buf))
         (vector (io-buffer-buffer buf))
         (b0 #+big-endian-target (ldb (byte 8 8) element)
             #+little-endian-target (ldb (byte 8 0) element))
         (b1 #+big-endian-target (ldb (byte 8 0) element)
             #+little-endian-target (ldb (byte 8 8) element)))
    (declare (fixnum idx limit count)
             (type (simple-array (unsigned-byte 8) (*)) vector)
             (type (unsigned-byte 8) b0 b1))
   
    (when (= idx limit)
      (%ioblock-force-output ioblock nil)
      (setq idx 0 count 0))
    (setf (aref vector idx) b1)
    (incf idx)
    (when (= idx limit)
      (when (> idx count)
        (setf (io-buffer-count buf) idx))
      (%ioblock-force-output ioblock nil)
      (setq idx 0 count 0))
    (setf (aref vector idx) b0)
    (incf idx)
    (setf (io-buffer-idx buf) idx)
    (when (> idx count)
      (setf (io-buffer-count buf) idx))
    (setf (ioblock-dirty ioblock) t)
    element))

(declaim (inline %ioblock-write-u32-code-unit))
(defun %ioblock-write-u32-code-unit (ioblock element)
  (declare (optimize (speed 3) (safety 0))
           (type (unsigned-byte 16) element))
  (let* ((buf (ioblock-outbuf ioblock))
         (idx (io-buffer-idx buf))
         (count (io-buffer-count buf))
         (limit (io-buffer-limit buf))
         (vector (io-buffer-buffer buf))
         (b0 #+big-endian-target (ldb (byte 8 24) element)
             #+little-endian-target (ldb (byte 8 0) element))
         (b1 #+big-endian-target (ldb (byte 8 16) element)
             #+little-endian-target (ldb (byte 8 8) element))
         (b2 #+big-endian-target (ldb (byte 8 8) element)
             #+little-endian-target (ldb (byte 8 16) element))
         (b3 #+big-endian-target (ldb (byte 8 0) element)
             #+little-endian-target (ldb (byte 8 24) element)))
    (declare (fixnum idx limit count)
             (type (simple-array (unsigned-byte 8) (*)) vector)
             (type (unsigned-byte 8) b0 b1 b2 b3))
    (when (= idx limit)
      (%ioblock-force-output ioblock nil)
      (setq idx 0 count 0))
    (setf (aref vector idx) b0)
    (incf idx)
    (when (= idx limit)
      (when (> idx count)
        (setf (io-buffer-count buf) idx))
      (%ioblock-force-output ioblock nil)
      (setq idx 0 count 0))
    (setf (aref vector idx) b1)
    (incf idx)
    (when (= idx limit)
      (when (> idx count)
        (setf (io-buffer-count buf) idx))
      (%ioblock-force-output ioblock nil)
      (setq idx 0 count 0))
    (setf (aref vector idx) b2)
    (incf idx)
    (when (= idx limit)
      (when (> idx count)
        (setf (io-buffer-count buf) idx))
      (%ioblock-force-output ioblock nil)
      (setq idx 0 count 0))
    (setf (aref vector idx) b3)
    (incf idx)
    (setf (io-buffer-idx buf) idx)
    (when (> idx count)
      (setf (io-buffer-count buf) idx))
    (setf (ioblock-dirty ioblock) t)
    element))

(declaim (inline %ioblock-write-swapped-u32-code-unit))
(defun %ioblock-write-swapped-u32-code-unit (ioblock element)
  (declare (optimize (speed 3) (safety 0))
           (type (unsigned-byte 16) element))
  (let* ((buf (ioblock-outbuf ioblock))
         (idx (io-buffer-idx buf))
         (count (io-buffer-count buf))
         (limit (io-buffer-limit buf))
         (vector (io-buffer-buffer buf))
         (b0 #+little-endian-target (ldb (byte 8 24) element)
             #+big-endian-target (ldb (byte 8 0) element))
         (b1 #+little-endian-target (ldb (byte 8 16) element)
             #+big-endian-target (ldb (byte 8 8) element))
         (b2 #+little-endian-target (ldb (byte 8 8) element)
             #+big-endian-target (ldb (byte 8 16) element))
         (b3 #+little-endian-target (ldb (byte 8 0) element)
             #+big-endian-target (ldb (byte 8 24) element)))
    (declare (fixnum idx limit count)
             (type (simple-array (unsigned-byte 8) (*)) vector)
             (type (unsigned-byte 8) b0 b1 b2 b3))
    (when (= idx limit)
      (%ioblock-force-output ioblock nil)
      (setq idx 0 count 0))
    (setf (aref vector idx) b0)
    (incf idx)
    (when (= idx limit)
      (when (> idx count)
        (setf (io-buffer-count buf) idx))
      (%ioblock-force-output ioblock nil)
      (setq idx 0 count 0))
    (setf (aref vector idx) b1)
    (incf idx)
    (when (= idx limit)
      (when (> idx count)
        (setf (io-buffer-count buf) idx))
      (%ioblock-force-output ioblock nil)
      (setq idx 0 count 0))
    (setf (aref vector idx) b2)
    (incf idx)
    (when (= idx limit)
      (when (> idx count)
        (setf (io-buffer-count buf) idx))
      (%ioblock-force-output ioblock nil)
      (setq idx 0 count 0))
    (setf (aref vector idx) b3)
    (incf idx)
    (setf (io-buffer-idx buf) idx)
    (when (> idx count)
      (setf (io-buffer-count buf) idx))
    (setf (ioblock-dirty ioblock) t)
    element))

(declaim (inline %ioblock-write-s16-element))
(defun %ioblock-write-s16-element (ioblock element)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((buf (ioblock-outbuf ioblock))
         (idx (io-buffer-idx buf))
         (count (io-buffer-count buf))
         (limit (io-buffer-limit buf)))
    (declare (fixnum idx limit count))
    (when (= idx limit)
      (%ioblock-force-output ioblock nil)
      (setq idx 0 count 0))
    (setf (aref (the (simple-array (signed-byte 16) (*)) (io-buffer-buffer buf)) idx) element)
    (incf idx)
    (setf (io-buffer-idx buf) idx)
    (when (> idx count)
      (setf (io-buffer-count buf) idx))
    (setf (ioblock-dirty ioblock) t)
    element))

(declaim (inline %ioblock-write-u32-element))
(defun %ioblock-write-u32-element (ioblock element)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((buf (ioblock-outbuf ioblock))
         (idx (io-buffer-idx buf))
         (count (io-buffer-count buf))
         (limit (io-buffer-limit buf)))
    (declare (fixnum idx limit count))
    (when (= idx limit)
      (%ioblock-force-output ioblock nil)
      (setq idx 0 count 0))
    (setf (aref (the (simple-array (unsigned-byte 32) (*)) (io-buffer-buffer buf)) idx) element)
    (incf idx)
    (setf (io-buffer-idx buf) idx)
    (when (> idx count)
      (setf (io-buffer-count buf) idx))
    (setf (ioblock-dirty ioblock) t)
    element))

(declaim (inline %ioblock-write-swapped-u32-element))
(defun %ioblock-write-swapped-u32-element (ioblock element)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((buf (ioblock-outbuf ioblock))
         (idx (io-buffer-idx buf))
         (count (io-buffer-count buf))
         (limit (io-buffer-limit buf)))
    (declare (fixnum idx limit count))
    (when (= idx limit)
      (%ioblock-force-output ioblock nil)
      (setq idx 0 count 0))
    (setf (aref (the (simple-array (unsigned-byte 32) (*)) (io-buffer-buffer buf)) idx)
          (%swap-u32 element))
    (incf idx)
    (setf (io-buffer-idx buf) idx)
    (when (> idx count)
      (setf (io-buffer-count buf) idx))
    (setf (ioblock-dirty ioblock) t)
    element))

(declaim (inline %ioblock-write-s32-element))
(defun %ioblock-write-s32-element (ioblock element)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((buf (ioblock-outbuf ioblock))
         (idx (io-buffer-idx buf))
         (count (io-buffer-count buf))
         (limit (io-buffer-limit buf)))
    (declare (fixnum idx limit count))
    (when (= idx limit)
      (%ioblock-force-output ioblock nil)
      (setq idx 0 count 0))
    (setf (aref (the (simple-array (signed-byte 32) (*)) (io-buffer-buffer buf)) idx) element)
    (incf idx)
    (setf (io-buffer-idx buf) idx)
    (when (> idx count)
      (setf (io-buffer-count buf) idx))
    (setf (ioblock-dirty ioblock) t)
    element))

#+64-bit-target
(progn
(declaim (inline %ioblock-write-u64-element))
(defun %ioblock-write-u64-element (ioblock element)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((buf (ioblock-outbuf ioblock))
         (idx (io-buffer-idx buf))
         (count (io-buffer-count buf))
         (limit (io-buffer-limit buf)))
    (declare (fixnum idx limit count))
    (when (= idx limit)
      (%ioblock-force-output ioblock nil)
      (setq idx 0 count 0))
    (setf (aref (the (simple-array (unsigned-byte 64) (*)) (io-buffer-buffer buf)) idx) element)
    (incf idx)
    (setf (io-buffer-idx buf) idx)
    (when (> idx count)
      (setf (io-buffer-count buf) idx))
    (setf (ioblock-dirty ioblock) t)
    element))

(declaim (inline %ioblock-write-s64-element))
(defun %ioblock-write-s64-element (ioblock element)
  (declare (optimize (speed 3) (safety 0)))
  (let* ((buf (ioblock-outbuf ioblock))
         (idx (io-buffer-idx buf))
         (count (io-buffer-count buf))
         (limit (io-buffer-limit buf)))
    (declare (fixnum idx limit count))
    (when (= idx limit)
      (%ioblock-force-output ioblock nil)
      (setq idx 0 count 0))
    (setf (aref (the (simple-array (signed-byte 64) (*)) (io-buffer-buffer buf)) idx) element)
    (incf idx)
    (setf (io-buffer-idx buf) idx)
    (when (> idx count)
      (setf (io-buffer-count buf) idx))
    (setf (ioblock-dirty ioblock) t)
    element))
)

(declaim (inline %ioblock-write-char))
(defun %ioblock-write-char (ioblock char)
  (declare (optimize (speed 3) (safety 0)))
  (if (eq char #\linefeed)
    (setf (ioblock-charpos ioblock) 0)
    (incf (ioblock-charpos ioblock)))
  (let* ((code (char-code char)))
    (declare (type (mod #x110000) code))
    (if (< code 256)
      (%ioblock-write-u8-element ioblock code)
      (%ioblock-write-u8-element ioblock (char-code #\Sub)))))

(defun %private-ioblock-write-char (ioblock char)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-write-char ioblock char))

(defun %locked-ioblock-write-char (ioblock char)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-output-lock-grabbed (ioblock)
    (%ioblock-write-char ioblock char)))

(declaim (inline %ioblock-write-u8-encoded-char))
(defun %ioblock-write-u8-encoded-char (ioblock char)
  (declare (optimize (speed 3) (safety 0)))
  (if (eq char #\linefeed)
    (setf (ioblock-charpos ioblock) 0)
    (incf (ioblock-charpos ioblock)))
  (let* ((code (char-code char)))
    (declare (type (mod #x110000) code))
    (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock)))
      (%ioblock-write-u8-element ioblock code)
      (funcall (ioblock-encode-output-function ioblock)
               char
               #'%ioblock-write-u8-element
               ioblock))))

(defun %private-ioblock-write-u8-encoded-char (ioblock char)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-write-u8-encoded-char ioblock char))

(defun %locked-ioblock-write-u8-encoded-char (ioblock char)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-output-lock-grabbed (ioblock) 
    (%ioblock-write-u8-encoded-char ioblock char)))


(defun %ioblock-write-u8-encoded-simple-string (ioblock string start-char num-chars)
  (declare (fixnum start-char num-chars)
           (simple-base-strng string)
           (optimize (speed 3) (safety 0)))
  (do* ((i 0 (1+ i))
        (col (ioblock-charpos ioblock))
        (limit (ioblock-encode-literal-char-code-limit ioblock))
        (encode-function (ioblock-encode-output-function ioblock))
        (start-char start-char (1+ start-char)))
       ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
    (declare (fixnum i start-char limit))
    (let* ((char (schar string start-char))
           (code (char-code char)))
      (declare (type (mod #x110000) code))
      (if (eq char #\newline)
        (setq col 0)
        (incf col))
      (if (< code limit)
               (%ioblock-write-u8-element ioblock code)
               (funcall encode-function char #'%ioblock-write-u8-element ioblock)))))


(declaim (inline %ioblock-write-u16-encoded-char))
(defun %ioblock-write-u16-encoded-char (ioblock char)
  (declare (optimize (speed 3) (safety 0)))
  (when (ioblock-pending-byte-order-mark ioblock)
    (setf (ioblock-pending-byte-order-mark ioblock) nil)
    (%ioblock-write-u16-code-unit ioblock byte-order-mark-char-code))
  (if (eq char #\linefeed)
    (setf (ioblock-charpos ioblock) 0)
    (incf (ioblock-charpos ioblock)))
  (let* ((code (char-code char)))
    (declare (type (mod #x110000) code))
    (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock)))
      (%ioblock-write-u16-code-unit ioblock code)
      (funcall (ioblock-encode-output-function ioblock)
               char
               #'%ioblock-write-u16-code-unit
               ioblock))))

(defun %private-ioblock-write-u16-encoded-char (ioblock char)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-write-u16-encoded-char ioblock char))

(defun %locked-ioblock-write-u16-encoded-char (ioblock char)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-output-lock-grabbed (ioblock)
    (%ioblock-write-u16-encoded-char ioblock char)))


(defun %ioblock-write-u16-encoded-simple-string (ioblock string start-char num-chars)
  (declare (fixnum start-char num-chars)
           (simple-base-strng string)
           (optimize (speed 3) (safety 0)))
  (when (ioblock-pending-byte-order-mark ioblock)
    (setf (ioblock-pending-byte-order-mark ioblock) nil)
    (%ioblock-write-u16-code-unit ioblock byte-order-mark-char-code))
  (do* ((i 0 (1+ i))
        (col (ioblock-charpos ioblock))
        (limit (ioblock-encode-literal-char-code-limit ioblock))
        (encode-function (ioblock-encode-output-function ioblock))
        (start-char start-char (1+ start-char)))
       ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
    (declare (fixnum i start-char limit))
    (let* ((char (schar string start-char))
           (code (char-code char)))
      (declare (type (mod #x110000) code))
      (if (eq char #\newline)
        (setq col 0)
        (incf col))
      (if (< code limit)
        (%ioblock-write-u16-code-unit ioblock code)
        (funcall encode-function char #'%ioblock-write-u16-code-unit ioblock)))))

(declaim (inline %ioblock-write-swapped-u16-encoded-char))
(defun %ioblock-write-swapped-u16-encoded-char (ioblock char)
  (declare (optimize (speed 3) (safety 0)))
  (if (eq char #\linefeed)
    (setf (ioblock-charpos ioblock) 0)
    (incf (ioblock-charpos ioblock)))
  (let* ((code (char-code char)))
    (declare (type (mod #x110000) code))
    (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock)))
      (%ioblock-write-swapped-u16-code-unit ioblock code)
      (funcall (ioblock-encode-output-function ioblock)
               char
               #'%ioblock-write-swapped-u16-code-unit
               ioblock))))

(defun %private-ioblock-write-swapped-u16-encoded-char (ioblock char)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-write-swapped-u16-encoded-char ioblock char))

(defun %locked-ioblock-write-swapped-u16-encoded-char (ioblock char)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-output-lock-grabbed (ioblock)
    (%ioblock-write-swapped-u16-encoded-char ioblock char)))

(defun %ioblock-write-swapped-u16-encoded-simple-string (ioblock string start-char num-chars)
  (declare (fixnum start-char num-chars)
           (simple-base-strng string)
           (optimize (speed 3) (safety 0)))
  (do* ((i 0 (1+ i))
        (col (ioblock-charpos ioblock))
        (limit (ioblock-encode-literal-char-code-limit ioblock))
        (encode-function (ioblock-encode-output-function ioblock))
        (wcf (ioblock-write-char-when-locked-function ioblock))
        (start-char start-char (1+ start-char)))
       ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
    (declare (fixnum i start-char limit))
    (let* ((char (schar string start-char))
           (code (char-code char)))
      (declare (type (mod #x110000) code))
      (cond ((eq char #\newline)
             (setq col 0)
             (funcall wcf ioblock char))
            (t
             (incf col)
             (if (< code limit)
               (%ioblock-write-swapped-u16-code-unit ioblock code)
               (funcall encode-function char #'%ioblock-write-swapped-u16-code-unit ioblock)))))))


(declaim (inline %ioblock-write-u32-encoded-char))
(defun %ioblock-write-u32-encoded-char (ioblock char)
  (declare (optimize (speed 3) (safety 0)))
  (when (ioblock-pending-byte-order-mark ioblock)
    (setf (ioblock-pending-byte-order-mark ioblock) nil)
    (%ioblock-write-u32-code-unit ioblock byte-order-mark))
  (if (eq char #\linefeed)
    (setf (ioblock-charpos ioblock) 0)
    (incf (ioblock-charpos ioblock)))
  (let* ((code (char-code char)))
    (declare (type (mod #x110000 code)))
    (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock)))
      (%ioblock-write-u32-code-unit ioblock code)
      (funcall (ioblock-encode-output-function ioblock)
               code
               #'%ioblock-write-u32-code-unit
               ioblock))))

(defun %private-ioblock-write-u32-encoded-char (ioblock char)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-write-u32-encoded-char ioblock char))

(defun %locked-ioblock-write-u32-encoded-char (ioblock char)
  (declare (optimize (speed 3) (safety 0)))  
  (with-ioblock-output-lock-grabbed (ioblock)
    (%ioblock-write-u32-encoded-char ioblock char)))

(defun %ioblock-write-u32-encoded-simple-string (ioblock string start-char num-chars)
  (declare (fixnum start-char num-chars)
           (simple-base-strng string)
           (optimize (speed 3) (safety 0)))
  (when (ioblock-pending-byte-order-mark ioblock)
    (setf (ioblock-pending-byte-order-mark ioblock) nil)
    (%ioblock-write-u32-code-unit ioblock byte-order-mark-char-code))
  (do* ((i 0 (1+ i))
        (col (ioblock-charpos ioblock))
        (limit (ioblock-encode-literal-char-code-limit ioblock))
        (encode-function (ioblock-encode-output-function ioblock))
        (start-char start-char (1+ start-char)))
       ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
    (declare (fixnum i start-char limit))
    (let* ((char (schar string start-char))
           (code (char-code char)))
      (declare (type (mod #x110000) code))
      (if (eq char #\newline)
        (setq col 0)
        (incf col))
      (if (< code limit)
        (%ioblock-write-u32-code-unit ioblock code)
        (funcall encode-function char #'%ioblock-write-u32-code-unit ioblock)))))


(declaim (inline %ioblock-write-swapped-u32-encoded-char))
(defun %ioblock-write-swapped-u32-encoded-char (ioblock char)
  (declare (optimize (speed 3) (safety 0)))
  (if (eq char #\linefeed)
    (setf (ioblock-charpos ioblock) 0)
    (incf (ioblock-charpos ioblock)))
  (let* ((code (char-code char)))
    (declare (type (mod #x110000 code)))
    (if (< code (the fixnum (ioblock-encode-literal-char-code-limit ioblock)))
      (%ioblock-write-swapped-u32-code-unit ioblock code)
      (funcall (ioblock-encode-output-function ioblock)
               code
               #'%ioblock-write-swapped-u32-code-unit
               ioblock))))

(defun %private-ioblock-write-swapped-u32-encoded-char (ioblock char)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-write-swapped-u32-encoded-char ioblock char))

(defun %locked-ioblock-write-swapped-u32-encoded-char (ioblock char)
  (declare (optimize (speed 3) (safety 0)))  
  (with-ioblock-output-lock-grabbed (ioblock)
    (%ioblock-write-swapped-u32-encoded-char ioblock char)))

(defun %ioblock-write-swapped-u32-encoded-simple-string (ioblock string start-char num-chars)
  (declare (fixnum start-char num-chars)
           (simple-base-strng string)
           (optimize (speed 3) (safety 0)))
  (do* ((i 0 (1+ i))
        (col (ioblock-charpos ioblock))
        (limit (ioblock-encode-literal-char-code-limit ioblock))
        (encode-function (ioblock-encode-output-function ioblock))
        (start-char start-char (1+ start-char)))
       ((= i num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
    (declare (fixnum i start-char limit))
    (let* ((char (schar string start-char))
           (code (char-code char)))
      (declare (type (mod #x110000) code))
      (if (eq char #\newline)
        (setq col 0)
        (incf col))
      (if (< code limit)
        (%ioblock-write-swapped-u32-code-unit ioblock code)
        (funcall encode-function char #'%ioblock-write-swapped-u32-code-unit ioblock)))))

(declaim (inline %ioblock-write-u8-byte))
(defun %ioblock-write-u8-byte (ioblock byte)
  (declare (optimize (speed 3) (safety 0)))
  (%ioblock-write-u8-element ioblock (require-type byte '(unsigned-byte 8))))

(defun %private-ioblock-write-u8-byte (ioblock byte)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-write-u8-byte ioblock byte))

(defun %locked-ioblock-write-u8-byte (ioblock byte)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-output-lock-grabbed (ioblock)
    (%ioblock-write-u8-byte ioblock byte)))

(declaim (inline %ioblock-write-s8-byte))
(defun %ioblock-write-s8-byte (ioblock byte)
  (declare (optimize (speed 3) (safety 0)))
  (%ioblock-write-s8-element ioblock (require-type byte '(signed-byte 8))))

(defun %private-ioblock-write-s8-byte (ioblock byte)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-write-s8-byte ioblock byte))

(defun %locked-ioblock-write-s8-byte (ioblock byte)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-output-lock-grabbed (ioblock)
    (%ioblock-write-s8-byte ioblock byte)))

(declaim (inline %ioblock-write-u16-byte))
(defun %ioblock-write-u16-byte (ioblock byte)
  (declare (optimize (speed 3) (safety 0)))
  (%ioblock-write-u16-element ioblock (require-type byte '(unsigned-byte 16))))

(defun %private-ioblock-write-u16-byte (ioblock byte)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-write-u16-byte ioblock byte))

(defun %locked-ioblock-write-u16-byte (ioblock byte)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-output-lock-grabbed (ioblock)
    (%ioblock-write-u16-byte ioblock byte)))

(declaim (inline %ioblock-write-s16-byte))
(defun %ioblock-write-s16-byte (ioblock byte)
  (declare (optimize (speed 3) (safety 0)))
  (%ioblock-write-s16-element ioblock (require-type byte '(signed-byte 16))))

(defun %private-ioblock-write-s16-byte (ioblock byte)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-write-s16-byte ioblock byte))

(defun %locked-ioblock-write-s16-byte (ioblock byte)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-output-lock-grabbed (ioblock)
    (%ioblock-write-s16-byte ioblock byte)))

(declaim (inline %ioblock-write-u32-byte))
(defun %ioblock-write-u32-byte (ioblock byte)
  (declare (optimize (speed 3) (safety 0)))
  (%ioblock-write-u32-element ioblock (require-type byte '(unsigned-byte 32))))

(defun %private-ioblock-write-u32-byte (ioblock byte)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-write-u32-byte ioblock byte))

(defun %locked-ioblock-write-u32-byte (ioblock byte)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-output-lock-grabbed (ioblock)
    (%ioblock-write-u32-byte ioblock byte)))

(declaim (inline %ioblock-write-s32-byte))
(defun %ioblock-write-s32-byte (ioblock byte)
  (declare (optimize (speed 3) (safety 0)))
  (%ioblock-write-s32-element ioblock (require-type byte '(signed-byte 32))))

(defun %private-ioblock-write-s32-byte (ioblock byte)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-write-s32-byte ioblock byte))

(defun %locked-ioblock-write-s32-byte (ioblock byte)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-output-lock-grabbed (ioblock)
    (%ioblock-write-s32-byte ioblock byte)))

#+64-bit-target
(progn
(declaim (inline %ioblock-write-u64-byte))
(defun %ioblock-write-u64-byte (ioblock byte)
  (declare (optimize (speed 3) (safety 0)))
  (%ioblock-write-u64-element ioblock (require-type byte '(unsigned-byte 64))))

(defun %private-ioblock-write-u64-byte (ioblock byte)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-write-u64-byte ioblock byte))

(defun %locked-ioblock-write-u64-byte (ioblock byte)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-output-lock-grabbed (ioblock)
    (%ioblock-write-u64-byte ioblock byte)))

(declaim (inline %ioblock-write-s64-byte))
(defun %ioblock-write-s64-byte (ioblock byte)
  (declare (optimize (speed 3) (safety 0)))
  (%ioblock-write-s64-element ioblock (require-type byte '(signed-byte 64))))

(defun %private-ioblock-write-s64-byte (ioblock byte)
  (declare (optimize (speed 3) (safety 0)))
  (check-ioblock-owner ioblock)
  (%ioblock-write-s64-byte ioblock byte))

(defun %locked-ioblock-write-s64-byte (ioblock byte)
  (declare (optimize (speed 3) (safety 0)))
  (with-ioblock-output-lock-grabbed (ioblock)
    (%ioblock-write-s64-byte ioblock byte)))
)                                       ;#+64-bit-target

(defun %ioblock-clear-output (ioblock)
  (let* ((buf (ioblock-outbuf ioblock)))                      
    (setf (io-buffer-count buf) 0
            (io-buffer-idx buf) 0)))

(defun %ioblock-unencoded-read-line (ioblock)
  (let* ((inbuf (ioblock-inbuf ioblock)))
    (let* ((string "")
           (len 0)
           (eof nil)
           (buf (io-buffer-buffer inbuf))
           (newline (char-code #\newline)))
      (let* ((ch (ioblock-untyi-char ioblock)))
        (when ch
          (setf (ioblock-untyi-char ioblock) nil)
          (if (eql ch #\newline)
            (return-from %ioblock-unencoded-read-line 
              (values string nil))
            (progn
              (setq string (make-string 1)
                    len 1)
              (setf (schar string 0) ch)))))
      (loop
        (let* ((more 0)
               (idx (io-buffer-idx inbuf))
               (count (io-buffer-count inbuf)))
          (declare (fixnum idx count more))
          (if (= idx count)
            (if eof
              (return (values string t))
              (progn
                (setq eof t)
                (%ioblock-advance ioblock t)))
            (progn
              (setq eof nil)
              (let* ((pos (position newline buf :start idx :end count)))
                (when pos
                  (locally (declare (fixnum pos))
                    (setf (io-buffer-idx inbuf) (the fixnum (1+ pos)))
                    (setq more (- pos idx))
                    (unless (zerop more)
                      (setq string
                            (%extend-vector
                             0 string (the fixnum (+ len more)))))
                    (%copy-u8-to-string
                     buf idx string len more)
                    (return (values string nil))))
                ;; No #\newline in the buffer.  Read everything that's
                ;; there into the string, and fill the buffer again.
                (setf (io-buffer-idx inbuf) count)
                (setq more (- count idx)
                      string (%extend-vector
                              0 string (the fixnum (+ len more))))
                (%copy-u8-to-string
                 buf idx string len more)
                (incf len more)))))))))

;;; There are lots of ways of doing better here, but in the most general
;;; case we can't tell (a) what a newline looks like in the buffer or (b)
;;; whether there's a 1:1 mapping between code units and characters.
(defun %ioblock-encoded-read-line (ioblock)
  (let* ((str (make-array 20 :element-type 'base-char
                          :adjustable t :fill-pointer 0))
         (rcf (ioblock-read-char-when-locked-function ioblock))
         (eof nil))
    (do* ((ch (funcall rcf ioblock) (funcall rcf ioblock)))
         ((or (eq ch #\newline) (setq eof (eq ch :eof)))
          (values (ensure-simple-string str) eof))
      (vector-push-extend ch str))))
         
(defun %ioblock-unencoded-character-read-vector (ioblock vector start end)
  (do* ((i start)
        (in (ioblock-inbuf ioblock))
        (inbuf (io-buffer-buffer in))
        (need (- end start)))
       ((= i end) end)
    (declare (fixnum i need))
    (let* ((ch (%ioblock-tyi ioblock)))
      (if (eq ch :eof)
        (return i))
      (setf (schar vector i) ch)
      (incf i)
      (decf need)
      (let* ((idx (io-buffer-idx in))
             (count (io-buffer-count in))
             (avail (- count idx)))
        (declare (fixnum idx count avail))
        (unless (zerop avail)
          (if (> avail need)
            (setq avail need))
          (%copy-u8-to-string inbuf idx vector i avail)
          (setf (io-buffer-idx in) (+ idx avail))
          (incf i avail)
          (decf need avail))))))

;;; Also used when newline translation complicates things.
(defun %ioblock-encoded-character-read-vector (ioblock vector start end)
  (declare (fixnum start end))
  (do* ((i start (1+ i))
        (rcf (ioblock-read-char-when-locked-function ioblock)))
       ((= i end) end)
    (declare (fixnum i need))
    (let* ((ch (funcall rcf ioblock)))
      (if (eq ch :eof)
        (return i))
      (setf (schar vector i) ch))))


(defun %ioblock-binary-read-vector (ioblock vector start end)
  (declare (fixnum start end))
  (let* ((in (ioblock-inbuf ioblock))
         (inbuf (io-buffer-buffer in))
         (rbf (ioblock-read-byte-when-locked-function ioblock)))
    (setf (ioblock-untyi-char ioblock) nil)
    (if (not (= (the fixnum (typecode inbuf))
                (the fixnum (typecode vector))))
      (do* ((i start (1+ i)))
           ((= i end) i)
        (declare (fixnum i))
        (let* ((b (funcall rbf ioblock)))
          (if (eq b :eof)
            (return i)
            (setf (uvref vector i) b))))
      (do* ((i start)
            (need (- end start)))
           ((= i end) end)
        (declare (fixnum i need))
        (let* ((b (funcall rbf ioblock)))
          (if (eq b :eof)
            (return i))
          (setf (uvref vector i) b)
          (incf i)
          (decf need)
          (let* ((idx (io-buffer-idx in))
                 (count (io-buffer-count in))
                 (avail (- count idx)))
            (declare (fixnum idx count avail))
            (unless (zerop avail)
              (if (> avail need)
                (setq avail need))
              (%copy-ivector-to-ivector
               inbuf
               (ioblock-elements-to-octets ioblock idx)
               vector
               (ioblock-elements-to-octets ioblock i)
               (ioblock-elements-to-octets ioblock avail))
              (setf (io-buffer-idx in) (+ idx avail))
              (incf i avail)
              (decf need avail))))))))

;;; About the same, only less fussy about ivector's element-type.
;;; (All fussiness is about the stream's element-type ...).
;;; Whatever the element-type is, elements must be 1 octet in size.
(defun %ioblock-character-in-ivect (ioblock vector start nb)
  (declare (type (simple-array (unsigned-byte 8) (*)) vector)
           (fixnum start nb)
           (optimize (speed 3) (safety 0)))
  (unless (= 0 (the fixnum (ioblock-element-shift ioblock)))
    (error "Can't read vector from stream ~s" (ioblock-stream ioblock)))
  (do* ((i start)
        (in (ioblock-inbuf ioblock))
        (inbuf (io-buffer-buffer in))
        (need nb)
        (end (+ start nb)))
       ((= i end) end)
    (declare (fixnum i end need))
    (let* ((ch (%ioblock-tyi ioblock)))
      (if (eq ch :eof)
        (return (- i start)))
      (setf (aref vector i) (char-code ch))
      (incf i)
      (decf need)
      (let* ((idx (io-buffer-idx in))
             (count (io-buffer-count in))
             (avail (- count idx)))
        (declare (fixnum idx count avail))
        (unless (zerop avail)
          (if (> avail need)
            (setq avail need))
          (%copy-u8-to-string inbuf idx vector i avail)
          (setf (io-buffer-idx in) (+ idx avail))
          (incf i avail)
          (decf need avail))))))

(defun %ioblock-binary-in-ivect (ioblock vector start nb)
  (declare (type (simple-array (unsigned-byte 8) (*)) vector)
           (fixnum start nb)
           (optimize (speed 3) (safety 0)))
  (unless (= 0 (the fixnum (ioblock-element-shift ioblock)))
    (error "Can't read vector from stream ~s" (ioblock-stream ioblock)))
  (setf (ioblock-untyi-char ioblock) nil)
  (do* ((i start)
        (rbf (ioblock-read-byte-when-locked-function ioblock))
        (in (ioblock-inbuf ioblock))
        (inbuf (io-buffer-buffer in))
        (need nb)
        (end (+ start nb)))
       ((= i end) nb)
    (declare (fixnum i end need))
    (let* ((b (funcall rbf ioblock)))
      (if (eq b :eof)
        (return (- i start)))
      (setf (uvref vector i) b)
      (incf i)
      (decf need)
      (let* ((idx (io-buffer-idx in))
             (count (io-buffer-count in))
             (avail (- count idx)))
        (declare (fixnum idx count avail))
        (unless (zerop avail)
          (if (> avail need)
            (setq avail need))
          (%copy-ivector-to-ivector inbuf idx vector i avail)
          (setf (io-buffer-idx in) (+ idx avail))
          (incf i avail)
          (decf need avail))))))

(defun %ioblock-close (ioblock)
  (let* ((stream (ioblock-stream ioblock)))
      (funcall (ioblock-close-function ioblock) stream ioblock)
      (setf (stream-ioblock stream) nil)
      (let* ((in-iobuf (ioblock-inbuf ioblock))
             (out-iobuf (ioblock-outbuf ioblock))
             (in-buffer (if in-iobuf (io-buffer-buffer in-iobuf)))
             (in-bufptr (if in-iobuf (io-buffer-bufptr in-iobuf)))
             (out-buffer (if out-iobuf (io-buffer-buffer out-iobuf)))
             (out-bufptr (if out-iobuf (io-buffer-bufptr out-iobuf))))
        (if (and in-buffer in-bufptr)
          (%dispose-heap-ivector in-buffer))
        (unless (eq in-buffer out-buffer)
          (if (and out-buffer out-bufptr)
            (%dispose-heap-ivector out-buffer)))
        (when in-iobuf
          (setf (io-buffer-buffer in-iobuf) nil
                (io-buffer-bufptr in-iobuf) nil
                (ioblock-inbuf ioblock) nil))
        (when out-iobuf
          (setf (io-buffer-buffer out-iobuf) nil
                (io-buffer-bufptr out-iobuf) nil
                (ioblock-outbuf ioblock) nil)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Character-at-a-time line-termination-translation functions.
;;; It's not always possible to just blast through the buffer, blindly
;;; replacing #xd with #xa (for example), and it's not always desirable
;;; to do that (if we support changing encoding on open streams.)
;;; This is done at a fairly high level; some cases could be done at
;;; a lower level, and some cases are hard even at that lower level.
;;; This approach doesn't slow down the simple case (when no line-termination
;;; translation is used), and hopefully isn't -that- bad.

(declaim (inline %ioblock-read-char-translating-cr-to-newline))
(defun %ioblock-read-char-translating-cr-to-newline (ioblock)
  (let* ((ch (funcall
              (ioblock-read-char-without-translation-when-locked-function
               ioblock)
              ioblock)))
    (if (eql ch #\Return)
      #\Newline
      ch)))

(defun %private-ioblock-read-char-translating-cr-to-newline (ioblock)
  (check-ioblock-owner ioblock)
  (%ioblock-read-char-translating-cr-to-newline ioblock))

(defun %locked-ioblock-read-char-translating-cr-to-newline (ioblock)
  (with-ioblock-input-lock-grabbed (ioblock)
    (%ioblock-read-char-translating-cr-to-newline ioblock)))

(declaim (inline %ioblock-read-char-translating-crlf-to-newline))
(defun %ioblock-read-char-translating-crlf-to-newline (ioblock)
  (let* ((ch (funcall
              (ioblock-read-char-without-translation-when-locked-function
               ioblock)
              ioblock)))
    (if (eql ch #\Return)
      (let* ((next (funcall
                    (ioblock-read-char-without-translation-when-locked-function
                     ioblock)
                    ioblock)))
        (if (eql next #\Linefeed)
          next
          (progn
            (unless (eq next :eof)
              (setf (ioblock-untyi-char ioblock) next))
            ch)))
      ch)))
    
(defun %private-ioblock-read-char-translating-crlf-to-newline (ioblock)
  (check-ioblock-owner ioblock)
  (%ioblock-read-char-translating-crlf-to-newline ioblock))

(defun %locked-ioblock-read-char-translating-crlf-to-newline (ioblock)
  (with-ioblock-input-lock-grabbed (ioblock)
    (%ioblock-read-char-translating-crlf-to-newline ioblock)))

(declaim (inline %ioblock-read-char-translating-line-separator-to-newline))
(defun %ioblock-read-char-translating-line-separator-to-newline (ioblock)
  (let* ((ch (funcall
              (ioblock-read-char-without-translation-when-locked-function
               ioblock)
              ioblock)))
    (if (eql ch #\Line_Separator)
      #\Newline
      ch)))

(defun %private-ioblock-read-char-translating-line-separator-to-newline (ioblock)
  (check-ioblock-owner ioblock)
  (%ioblock-read-char-translating-line-separator-to-newline ioblock))

(defun %locked-ioblock-read-char-translating-line-separator-to-newline (ioblock)
  (with-ioblock-input-lock-grabbed (ioblock)
    (%ioblock-read-char-translating-line-separator-to-newline ioblock)))

(declaim (inline %ioblock-write-char-translating-newline-to-cr))
(defun %ioblock-write-char-translating-newline-to-cr (ioblock char)
  (funcall (ioblock-write-char-without-translation-when-locked-function
            ioblock)
           ioblock
           (if (eql char #\Newline) #\Return char)))

(defun %private-ioblock-write-char-translating-newline-to-cr (ioblock char)
  (check-ioblock-owner ioblock)
  (%ioblock-write-char-translating-newline-to-cr ioblock char))

(defun %locked-ioblock-write-char-translating-newline-to-cr (ioblock char)
  (with-ioblock-input-lock-grabbed (ioblock)
    (%ioblock-write-char-translating-newline-to-cr ioblock char)))

(declaim (inline %ioblock-write-char-translating-newline-to-crlf))
(defun %ioblock-write-char-translating-newline-to-crlf (ioblock char)
  (when (eql char #\Newline)
    (funcall (ioblock-write-char-without-translation-when-locked-function
              ioblock)
             ioblock
             #\Return))    
  (funcall (ioblock-write-char-without-translation-when-locked-function
            ioblock)
           ioblock
           char))

(defun %private-ioblock-write-char-translating-newline-to-crlf (ioblock char)
  (check-ioblock-owner ioblock)
  (%ioblock-write-char-translating-newline-to-crlf ioblock char))

(defun %locked-ioblock-write-char-translating-newline-to-crlf (ioblock char)
  (with-ioblock-input-lock-grabbed (ioblock)
    (%ioblock-write-char-translating-newline-to-crlf ioblock char)))

(declaim (inline %ioblock-write-char-translating-newline-to-line-separator))
(defun %ioblock-write-char-translating-newline-to-line-separator (ioblock char)
  (funcall (ioblock-write-char-without-translation-when-locked-function
            ioblock)
           ioblock
           (if (eql char #\Newline) #\Line_Separator char)))

(defun %private-ioblock-write-char-translating-newline-to-line-separator (ioblock char)
  (check-ioblock-owner ioblock)
  (%ioblock-write-char-translating-newline-to-line-separator ioblock char))

(defun %locked-ioblock-write-char-translating-newline-to-line-separator (ioblock char)
  (with-ioblock-input-lock-grabbed (ioblock)
    (%ioblock-write-char-translating-newline-to-line-separator ioblock char)))

;;; If we do newline translation, we probably can't be too clever about reading/writing
;;; strings.
(defun %ioblock-write-simple-string-with-newline-translation (ioblock string start-pos num-chars)
  (declare (fixnum start-char num-chars) (simple-string string))
  (let* ((col (ioblock-charpos ioblock))
         (wcf (ioblock-write-char-when-locked-function ioblock)))
    (declare (fixnum col))
    (do* ((i start-pos (1+ i))
          (n 0 (1+ n)))
         ((= n num-chars) (setf (ioblock-charpos ioblock) col) num-chars)
      (let* ((char (schar string i)))
        (if (eql char #\Newline)
          (setq col 0)
          (incf col))
        (funcall wcf ioblock char)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defun setup-ioblock-input (ioblock character-p element-type sharing encoding line-termination)
  (setf (ioblock-sharing ioblock) sharing)
  (when character-p
    (setf (ioblock-unread-char-function ioblock) '%ioblock-untyi)
    (setf (ioblock-decode-literal-code-unit-limit ioblock)
          (if encoding
            (character-encoding-decode-literal-code-unit-limit encoding)
            256))    
    (if encoding
      (let* ((unit-size (character-encoding-code-unit-size encoding)))
        (setf (ioblock-peek-char-function ioblock) '%encoded-ioblock-peek-char)
        (setf (ioblock-read-line-function ioblock)
              '%ioblock-encoded-read-line)
        (setf (ioblock-character-read-vector-function ioblock)
              '%ioblock-encoded-character-read-vector)        
        (setf (ioblock-decode-input-function ioblock)
              (character-encoding-stream-decode-function encoding))
        (setf (ioblock-read-char-function ioblock)
              (ecase unit-size
                (8
                 (setf (ioblock-read-char-when-locked-function ioblock)
                       '%ioblock-read-u8-encoded-char)
                 (case sharing
                   (:private '%private-ioblock-read-u8-encoded-char)
                   (:lock '%locked-ioblock-read-u8-encoded-char)
                   (t '%ioblock-read-u8-encoded-char)))
                (16
                 (if (character-encoding-native-endianness encoding)
                   (progn
                    (setf (ioblock-read-char-when-locked-function ioblock)
                          '%ioblock-read-u16-encoded-char)
                    (case sharing
                      (:private '%private-ioblock-read-u16-encoded-char)
                      (:lock '%locked-ioblock-read-u16-encoded-char)
                      (t '%ioblock-read-u16-encoded-char)))
                   (progn
                     (setf (ioblock-read-char-when-locked-function ioblock)
                           '%ioblock-read-swapped-u16-encoded-char)
                    (case sharing
                      (:private '%private-ioblock-read-swapped-u16-encoded-char)
                      (:lock '%locked-ioblock-read-swapped-u16-encoded-char)
                      (t '%ioblock-read-swapped-u16-encoded-char)))))
                (32
                 (if (character-encoding-native-endianness encoding)
                   (progn
                    (setf (ioblock-read-char-when-locked-function ioblock)
                          #'%ioblock-read-u32-encoded-char)
                    (case sharing
                      (:private #'%private-ioblock-read-u32-encoded-char)
                      (:lock #'%locked-ioblock-read-u32-encoded-char)
                      (t #'%ioblock-read-u32-encoded-char)))
                   (progn
                     (setf (ioblock-read-char-when-locked-function ioblock)
                           #'%ioblock-read-swapped-u32-encoded-char)
                    (case sharing
                      (:private '#'%private-ioblock-read-swapped-u16-encoded-char)
                      (:lock #'%locked-ioblock-read-swapped-u32-encoded-char)
                      (t #'%ioblock-read-swapped-u32-encoded-char))))))))
      (progn
        (setf (ioblock-peek-char-function ioblock) '%ioblock-peek-char)
        (setf (ioblock-read-char-function ioblock)
              (case sharing
                (:private '%private-ioblock-tyi)
                (:lock '%locked-ioblock-tyi)
                (t '%ioblock-tyi)))
        (setf (ioblock-read-char-when-locked-function ioblock)
              '%ioblock-tyi)
        (setf (ioblock-character-read-vector-function ioblock)
              '%ioblock-unencoded-character-read-vector)
        (setf (ioblock-read-line-function ioblock)
              '%ioblock-unencoded-read-line)))
    (when line-termination
      (install-ioblock-input-line-termination ioblock line-termination))
    )

  (unless (or (eq element-type 'character)
              (subtypep element-type 'character))
    (let* ((subtag (element-type-subtype element-type)))
      (declare (type (unsigned-byte 8) subtag))
      (setf (ioblock-read-byte-function ioblock)
            (cond ((= subtag target::subtag-u8-vector)
                   (if character-p
                     ;; The bivalent case, at least for now
                     (progn
                       (setf (ioblock-read-byte-when-locked-function ioblock)
                             '%bivalent-ioblock-read-u8-byte)
                       (case sharing
                         (:private '%bivalent-private-ioblock-read-u8-byte)
                         (:lock '%bivalent-locked-ioblock-read-u8-byte)
                         (t '%bivalent-ioblock-read-u8-byte)))
                     (progn
                       (setf (ioblock-read-byte-when-locked-function ioblock)
                             '%ioblock-read-u8-byte)
                       (case sharing
                         (:private '%private-ioblock-read-u8-byte)
                         (:lock '%locked-ioblock-read-u8-byte)
                         (t '%ioblock-read-u8-byte)))))
                  ((= subtag target::subtag-s8-vector)
                   (setf (ioblock-read-byte-when-locked-function ioblock)
                         '%ioblock-read-s8-byte) 
                   (case sharing
                     (:private '%private-ioblock-read-s8-byte)
                     (:lock '%locked-ioblock-read-s8-byte)
                     (t '%ioblock-read-s8-byte)))
                  ((= subtag target::subtag-u16-vector)
                   (setf (ioblock-read-byte-when-locked-function ioblock)
                         '%ioblock-read-u16-byte)
                   (case sharing
                     (:private '%private-ioblock-read-u16-byte)
                     (:lock '%locked-ioblock-read-u16-byte)
                     (t '%ioblock-read-u16-byte)))
                  ((= subtag target::subtag-s16-vector)
                   (setf (ioblock-read-byte-when-locked-function ioblock)
                         '%ioblock-read-s16-byte)
                   (case sharing
                     (:private '%private-ioblock-read-s16-byte)
                     (:lock '%locked-ioblock-read-s16-byte)
                     (t '%ioblock-read-s16-byte)))
                  ((= subtag target::subtag-u32-vector)
                   (setf (ioblock-read-byte-when-locked-function ioblock)
                         '%ioblock-read-u32-byte)
                   (case sharing
                     (:private '%private-ioblock-read-u32-byte)
                     (:lock '%locked-ioblock-read-u32-byte)
                     (t '%ioblock-read-u32-byte)))
                  ((= subtag target::subtag-s32-vector)
                   (setf (ioblock-read-byte-when-locked-function ioblock)
                         '%ioblock-read-s32-byte)                   
                   (case sharing
                     (:private '%private-ioblock-read-s32-byte)
                     (:lock '%locked-ioblock-read-s32-byte)
                     (t '%ioblock-read-s32-byte)))
                  #+64-bit-target
                  ((= subtag target::subtag-u64-vector)
                   (setf (ioblock-read-byte-when-locked-function ioblock)
                         '%ioblock-read-u64-byte)                   
                   (case sharing
                     (:private '%private-ioblock-read-u64-byte)
                     (:lock '%locked-ioblock-read-u64-byte)
                     (t '%ioblock-read-u64-byte)))
                  #+64-bit-target
                  ((= subtag target::subtag-s64-vector)
                   (setf (ioblock-read-byte-when-locked-function ioblock)
                         '%ioblock-read-s64-byte)
                   (case sharing
                     (:private '%private-ioblock-read-s64-byte)
                     (:lock '%locked-ioblock-read-s64-byte)
                     (t '%ioblock-read-s64-byte)))
                  ;; Not sure what this means, currently.
                  (t
                   (setf (ioblock-read-byte-when-locked-function ioblock)
                         '%general-ioblock-read-byte)
                   '%general-ioblock-read-byte))))))

(defun install-ioblock-input-line-termination (ioblock line-termination)
  (when line-termination
    (let* ((sharing (ioblock-sharing ioblock)))
      (setf (ioblock-read-char-without-translation-when-locked-function ioblock)
            (ioblock-read-char-when-locked-function ioblock)
            (ioblock-character-read-vector-function ioblock)
            '%ioblock-encoded-character-read-vector
            (ioblock-read-line-function ioblock) '%ioblock-encoded-read-line)
      (ecase line-termination
        (:cr (setf (ioblock-read-char-when-locked-function ioblock)
                   '%ioblock-read-char-translating-cr-to-newline
                   (ioblock-read-char-function ioblock)
                   (case sharing
                     (:private
                      '%private-ioblock-read-char-translating-cr-to-newline)
                     (:lock
                      '%locked-ioblock-read-char-translating-cr-to-newline)
                     (t '%ioblock-read-char-translating-cr-to-newline))))
        (:crlf (setf (ioblock-read-char-when-locked-function ioblock)
                     '%ioblock-read-char-translating-crlf-to-newline
                     (ioblock-read-char-function ioblock)
                     (case sharing
                       (:private
                        '%private-ioblock-read-char-translating-crlf-to-newline)
                       (:lock
                        '%locked-ioblock-read-char-translating-crlf-to-newline)
                       (t '%ioblock-read-char-translating-crlf-to-newline))))
        (:unicode (setf (ioblock-read-char-when-locked-function ioblock)
                        '%ioblock-read-char-translating-line-separator-to-newline
                        (ioblock-read-char-function ioblock)
                        (case sharing
                          (:private
                           '%private-ioblock-read-char-translating-line-separator-to-newline)
                          (:lock
                           '%locked-ioblock-read-char-translating-line-separator-to-newline)
                          (t '%ioblock-read-char-translating-line-separator-to-newline))))))))
  
(defun setup-ioblock-output (ioblock character-p element-type sharing encoding line-termination)
  (or (ioblock-sharing ioblock)
      (setf (ioblock-sharing ioblock) sharing))
  (when character-p
    (setf (ioblock-encode-literal-char-code-limit ioblock)
          (if encoding
            (character-encoding-encode-literal-char-code-limit encoding)
            256))    
    (if encoding
      (let* ((unit-size (character-encoding-code-unit-size encoding)))
        (setf (ioblock-encode-output-function ioblock)
              (character-encoding-stream-encode-function encoding))
        (setf (ioblock-write-char-function ioblock)
              (ecase unit-size
                (8
                 (setf (ioblock-write-char-when-locked-function ioblock)
                       '%ioblock-write-u8-encoded-char) 
                 (case sharing
                   (:private '%private-ioblock-write-u8-encoded-char)
                   (:lock '%locked-ioblock-write-u8-encoded-char)
                   (t '%ioblock-write-u8-encoded-char)))
                (16
                 (if (character-encoding-native-endianness encoding)
                   (progn
                     (setf (ioblock-write-char-when-locked-function ioblock)
                           '%ioblock-write-u16-encoded-char) 
                     (case sharing
                       (:private '%private-ioblock-write-u16-encoded-char)
                       (:lock '%locked-ioblock-write-u16-encoded-char)
                       (t '%ioblock-write-u16-encoded-char)))
                   (progn
                     (setf (ioblock-write-char-when-locked-function ioblock)
                           '%ioblock-write-swapped-u16-encoded-char)
                     (case sharing
                       (:private '%private-ioblock-write-swapped-u16-encoded-char)
                       (:lock '%locked-ioblock-write-swapped-u16-encoded-char)
                       (t '%ioblock-write-swapped-u16-encoded-char)))))
                (32
                 (if (character-encoding-native-endianness encoding)
                   (progn
                     (setf (ioblock-write-char-when-locked-function ioblock)
                           #'%ioblock-write-u32-encoded-char) 
                     (case sharing
                       (:private #'%private-ioblock-write-u32-encoded-char)
                       (:lock #'%locked-ioblock-write-u32-encoded-char)
                       (t #'%ioblock-write-u32-encoded-char)))
                   (progn
                     (setf (ioblock-write-char-when-locked-function ioblock)
                           #'%ioblock-write-swapped-u32-encoded-char)
                     (case sharing
                       (:private #'%private-ioblock-write-swapped-u32-encoded-char)
                       (:lock #'%locked-ioblock-write-swapped-u32-encoded-char)
                       (t #'%ioblock-write-swapped-u32-encoded-char)))))))
        (setf (ioblock-write-simple-string-function ioblock)
              (ecase unit-size
                (8 '%ioblock-write-u8-encoded-simple-string)
                (16
                 (if (character-encoding-native-endianness encoding)
                   '%ioblock-write-u16-encoded-simple-string
                   '%ioblock-write-swapped-u16-encoded-simple-string))
                (32
                 (if (character-encoding-native-endianness encoding)
                   #'%ioblock-write-u32-encoded-simple-string
                   #'%ioblock-write-swapped-u32-encoded-simple-string))))
        (when (character-encoding-use-byte-order-mark encoding)
          (setf (ioblock-pending-byte-order-mark ioblock) t)))
      (progn
        (setf (ioblock-write-simple-string-function ioblock)
              '%ioblock-unencoded-write-simple-string)
        (setf (ioblock-write-char-when-locked-function ioblock)
              '%ioblock-write-char)
        (setf (ioblock-write-char-function ioblock)
              (case sharing
                (:private '%private-ioblock-write-char)
                (:lock '%locked-ioblock-write-char)
                (t '%ioblock-write-char)))))
    (when line-termination
      (install-ioblock-output-line-termination ioblock line-termination)))
  (unless (or (eq element-type 'character)
              (subtypep element-type 'character))
    (let* ((subtag (element-type-subtype element-type)))
      (declare (type (unsigned-byte 8) subtag))
      (setf (ioblock-write-byte-function ioblock)
            (cond ((= subtag target::subtag-u8-vector)
                   (progn
                     (setf (ioblock-write-byte-when-locked-function ioblock)
                           '%ioblock-write-u8-byte)
                     (case sharing
                       (:private '%private-ioblock-write-u8-byte)
                       (:lock '%locked-ioblock-write-u8-byte)
                       (t '%ioblock-write-u8-byte))))
                  ((= subtag target::subtag-s8-vector)
                   (setf (ioblock-write-byte-when-locked-function ioblock)
                         '%ioblock-write-s8-byte)                   
                   (case sharing
                     (:private '%private-ioblock-write-s8-byte)
                     (:lock '%locked-ioblock-write-s8-byte)
                     (t '%ioblock-write-s8-byte)))
                  ((= subtag target::subtag-u16-vector)
                   (setf (ioblock-write-byte-when-locked-function ioblock)
                         '%ioblock-write-u16-byte)                   
                   (case sharing
                     (:private '%private-ioblock-write-u16-byte)
                     (:lock '%locked-ioblock-write-u16-byte)
                     (t '%ioblock-write-u16-byte)))
                  ((= subtag target::subtag-s16-vector)
                   (setf (ioblock-write-byte-when-locked-function ioblock)
                         '%ioblock-write-s16-byte)                                      
                   (case sharing
                     (:private '%private-ioblock-write-s16-byte)
                     (:lock '%locked-ioblock-write-s16-byte)
                     (t '%ioblock-write-s16-byte)))
                  ((= subtag target::subtag-u32-vector)
                   (setf (ioblock-write-byte-when-locked-function ioblock)
                         '%ioblock-write-u32-byte)                                      
                   (case sharing
                     (:private '%private-ioblock-write-u32-byte)
                     (:lock '%locked-ioblock-write-u32-byte)
                     (t '%ioblock-write-u32-byte)))
                  ((= subtag target::subtag-s32-vector)
                   (setf (ioblock-write-byte-when-locked-function ioblock)
                         '%ioblock-write-s32-byte)
                   (case sharing
                     (:private '%private-ioblock-write-s32-byte)
                     (:lock '%locked-ioblock-write-s32-byte)
                     (t '%ioblock-write-s32-byte)))
                  #+64-bit-target
                  ((= subtag target::subtag-u64-vector)
                   (setf (ioblock-write-byte-when-locked-function ioblock)
                         '%ioblock-write-u64-byte)
                   (case sharing
                     (:private '%private-ioblock-write-u64-byte)
                     (:lock '%locked-ioblock-write-u64-byte)
                     (t '%ioblock-write-u64-byte)))
                  #+64-bit-target
                  ((= subtag target::subtag-s64-vector)
                   (setf (ioblock-write-byte-when-locked-function ioblock)
                         '%ioblock-write-u64-byte)
                   (case sharing
                     (:private '%private-ioblock-write-s64-byte)
                     (:lock '%locked-ioblock-write-s64-byte)
                     (t '%ioblock-write-s64-byte)))
                  (t
                   (setf (ioblock-write-byte-when-locked-function ioblock)
                         '%general-ioblock-write-byte)                   
                   '%general-ioblock-write-byte))))))

(defun install-ioblock-output-line-termination (ioblock line-termination)
  (let* ((sharing (ioblock-sharing ioblock)))
        (when line-termination
      (setf (ioblock-write-char-without-translation-when-locked-function ioblock)
            (ioblock-write-char-when-locked-function ioblock)
            (ioblock-write-simple-string-function ioblock)
            '%ioblock-write-simple-string-with-newline-translation)
      (ecase line-termination
        (:cr (setf (ioblock-write-char-when-locked-function ioblock)
                   '%ioblock-write-char-translating-newline-to-cr
                   (ioblock-read-char-function ioblock)
                   (case sharing
                     (:private
                      '%private-ioblock-write-char-translating-newline-to-cr)
                     (:lock
                      '%locked-ioblock-write-char-translating-newline-to-cr)
                     (t '%ioblock-write-char-translating-newline-to-cr))))
        (:crlf (setf (ioblock-write-char-when-locked-function ioblock)
                     '%ioblock-write-char-translating-newline-to-crlf
                     (ioblock-write-char-function ioblock)
                     (case sharing
                       (:private
                        '%private-ioblock-write-char-translating-newline-to-crlf)
                       (:lock
                        '%locked-ioblock-write-char-translating-newline-to-crlf)
                       (t '%ioblock-write-char-translating-newline-to-crlf))))
        (:unicode (setf (ioblock-write-char-when-locked-function ioblock)
                        '%ioblock-write-char-translating-newline-to-line-separator
                        (ioblock-write-char-function ioblock)
                        (case sharing
                          (:private
                           '%private-ioblock-write-char-translating-newline-to-line-separator)
                          (:lock
                           '%locked-ioblock-write-char-translating-newline-to-line-separator)
                          (t '%ioblock-write-char-translating-newline-to-line-separator))))))))


(defun ensure-reasonable-element-type (element-type)
  (let* ((upgraded (upgraded-array-element-type element-type)))
    (if (eq upgraded 'bit)
      '(unsigned-byte 8)
      (if (eq upgraded 'fixnum)
        #+64-bit-target '(signed-byte 64) #+32-bit-target '(signed-byte 32)
        (if (eq upgraded t)
          (error "Stream element-type ~s can't be reasonably supported." element-type)
          upgraded)))))

(defun init-stream-ioblock (stream
                            &key
                            insize      ; integer to allocate inbuf here, nil
                                        ; otherwise
                            outsize     ; integer to allocate outbuf here, nil
                                        ; otherwise
                            share-buffers-p ; true if input and output
                                        ; share a buffer
                            element-type
                            device
                            advance-function
                            listen-function
                            eofp-function
                            force-output-function
                            close-function
                            element-shift
                            interactive
                            (sharing :private)
                            character-p
                            encoding
                            line-termination
                            &allow-other-keys)
  (declare (ignorable element-shift))
  (setq line-termination (cdr (assoc line-termination *canonical-line-termination-conventions*)))
  (when encoding
    (unless (typep encoding 'character-encoding)
      (setq encoding (get-character-encoding encoding)))
    (if (eq encoding (get-character-encoding nil))
      (setq encoding nil)))
  (when sharing
    (unless (or (eq sharing :private)
                (eq sharing :lock))
      (if (eq sharing :external)
        (setq sharing nil)
        (report-bad-arg sharing '(member nil :private :lock :external)))))
  (let* ((ioblock (or (let* ((ioblock (stream-ioblock stream nil)))
                        (when ioblock
                          (setf (ioblock-stream ioblock) stream)
                          ioblock))
                      (stream-create-ioblock stream))))
    (when (eq sharing :private)
      (setf (ioblock-owner ioblock) *current-process*))
    (setf (ioblock-encoding ioblock) encoding)
    (when insize
      (unless (ioblock-inbuf ioblock)
        (multiple-value-bind (buffer ptr in-size-in-octets)
            (make-heap-ivector insize
                               (if character-p
                                 '(unsigned-byte 8)
                                 (setq element-type
                                       (ensure-reasonable-element-type element-type))))
          (setf (ioblock-inbuf ioblock)
                (make-io-buffer :buffer buffer
                                :bufptr ptr
                                :size in-size-in-octets
                                :limit insize))
          (when (eq sharing :lock)
            (setf (ioblock-inbuf-lock ioblock) (make-lock)))
          (setf (ioblock-line-termination ioblock) line-termination)
          (setup-ioblock-input ioblock character-p element-type sharing encoding line-termination)
          (setf (ioblock-element-shift ioblock) (max 0 (ceiling (log  (/ in-size-in-octets insize) 2))))
          )))
    (if share-buffers-p
      (if insize
        (progn (setf (ioblock-outbuf ioblock)
                     (ioblock-inbuf ioblock))
               (setf (ioblock-outbuf-lock ioblock)
                     (ioblock-inbuf-lock ioblock)))
        (error "Can't share buffers unless insize is non-zero and non-null"))
      (when outsize
        (unless (ioblock-outbuf ioblock)
          (multiple-value-bind (buffer ptr out-size-in-octets)
              (make-heap-ivector outsize
                                 (if character-p
                                   '(unsigned-byte 8)
                                   (setq element-type (ensure-reasonable-element-type element-type))))
            (setf (ioblock-outbuf ioblock)
                  (make-io-buffer :buffer buffer
                                  :bufptr ptr
                                  :count 0
                                  :limit outsize
                                  :size out-size-in-octets))
            (when (eq sharing :lock)
              (setf (ioblock-outbuf-lock ioblock) (make-lock)))
            (setf (ioblock-element-shift ioblock) (max 0 (ceiling (log (/ out-size-in-octets outsize) 2))))
            ))))
    (when (or share-buffers-p outsize)
      (setup-ioblock-output ioblock character-p element-type sharing encoding line-termination))
    (when element-type
      (setf (ioblock-element-type ioblock) (if character-p 'character element-type)))
;    (when element-shift
;      (setf (ioblock-element-shift ioblock) element-shift))
    (when device
      (setf (ioblock-device ioblock) device))
    (when advance-function
      (setf (ioblock-advance-function ioblock) advance-function))
    (when listen-function
      (setf (ioblock-listen-function ioblock) listen-function))
    (when eofp-function
      (setf (ioblock-eofp-function ioblock) eofp-function))
    (when force-output-function
      (setf (ioblock-force-output-function ioblock) force-output-function))
    (when close-function
      (setf (ioblock-close-function ioblock) close-function))
    (when interactive
      (setf (ioblock-interactive ioblock) interactive))
    (setf (stream-ioblock stream) ioblock)
    (when encoding
      (setf (ioblock-native-byte-order ioblock)
            (character-encoding-native-endianness encoding)))
    (let* ((bom-info (and insize encoding (character-encoding-use-byte-order-mark encoding))))
      (when bom-info
        (ioblock-check-input-bom ioblock bom-info sharing)))
    ioblock))

;;; If there's a byte-order-mark (or a reversed byte-order-mark) at
;;; the beginning of the input stream, deal with it.  If there's any
;;; input present, make sure that we don't write a BOM on output.  If
;;; this is a little-endian machine, input data was present, and there
;;; was no BOM in that data, make things big-endian.  If there's a
;;; leading BOM or swapped BOM, eat it (consume it so that it doesn't
;;; ordinarily appear as input.)
;;;
(defun ioblock-check-input-bom (ioblock swapped-encoding-name sharing)
  (let* ((n (%ioblock-advance ioblock nil))) ; try to read, don't block
    (when n
      (setf (ioblock-pending-byte-order-mark ioblock) nil)
      (let* ((inbuf (ioblock-inbuf ioblock))
             (unit-size (character-encoding-code-unit-size (ioblock-encoding ioblock)))
             (min (ash unit-size -3))
             (buf (io-buffer-buffer inbuf))
             (swapped-encoding
              (and
               (>= n min)
               (case (case unit-size
                       (16 (%native-u8-ref-u16 buf 0))
                       (32 (%native-u8-ref-u32 buf 0)))
                 (#.byte-order-mark-char-code
                  (setf (io-buffer-idx inbuf) min)
                  nil)
                 (#.swapped-byte-order-mark-char-code
                  (setf (io-buffer-idx inbuf) min)
                  t)
                 (t #+little-endian-target t))
               (lookup-character-encoding swapped-encoding-name))))
        (when swapped-encoding
          (let* ((output-p (not (null (ioblock-outbuf ioblock)))))
            (setf (ioblock-native-byte-order ioblock)
                  (character-encoding-native-endianness swapped-encoding))
            (ecase unit-size
              (16
               (setf (ioblock-read-char-when-locked-function ioblock)
                     '%ioblock-read-swapped-u16-encoded-char)
               (case sharing
                 (:private '%private-ioblock-read-swapped-u16-encoded-char)
                 (:lock '%locked-ioblock-read-swapped-u16-encoded-char)
                 (t '%ioblock-read-swapped-u16-encoded-char)))
              (32
               (setf (ioblock-read-char-when-locked-function ioblock)
                     '%ioblock-read-swapped-u32-encoded-char)
               (case sharing
                 (:private '%private-ioblock-read-swapped-u32-encoded-char)
                 (:lock '%locked-ioblock-read-swapped-u32-encoded-char)
                 (t '%ioblock-read-swapped-u16-encoded-char))))
            (when output-p
              (ecase unit-size
                (16
                 (setf (ioblock-write-char-when-locked-function ioblock)
                       '%ioblock-write-swapped-u16-encoded-char)
                 (case sharing
                   (:private '%private-ioblock-write-swapped-u16-encoded-char)
                   (:lock '%locked-ioblock-write-swapped-u16-encoded-char)
                   (t '%ioblock-write-swapped-u16-encoded-char))
                 (setf (ioblock-write-simple-string-function ioblock)
                       '%ioblock-write-swapped-u16-encoded-simple-string))
                (32
                 (setf (ioblock-write-char-when-locked-function ioblock)
                       '%ioblock-write-swapped-u32-encoded-char)
                 (case sharing
                   (:private '%private-ioblock-write-swapped-u32-encoded-char)
                   (:lock '%locked-ioblock-write-swapped-u32-encoded-char)
                   (t '%ioblock-write-swapped-u32-encoded-char))
                 (setf (ioblock-write-simple-string-function ioblock)
                       '%ioblock-write-swapped-u32-encoded-simple-string))))))))))



;;; We can't define a MAKE-INSTANCE method on STRUCTURE-CLASS subclasses
;;; in MCL; of course, calling the structure-class's constructor does
;;; much the same thing (but note that MCL only keeps track of the
;;; default, automatically generated constructor.)
;;; (As fascinating as that may be, that has nothing to do with any
;;; nearby code, though it may have once been relevant.)
(defun make-ioblock-stream (class
                            &rest initargs
                            &key 
                            &allow-other-keys)
  (declare (dynamic-extent initargs))
  (let* ((s
          (if (subtypep class (find-class 'basic-stream))
            (apply #'make-basic-stream-instance class :allow-other-keys t initargs)
            (apply #'make-instance class :allow-other-keys t initargs))))
    (apply #'init-stream-ioblock s initargs)
    s))





(defmethod select-stream-class ((s symbol) in-p out-p char-p)
  (select-stream-class (class-prototype (find-class s)) in-p out-p char-p))

(defmethod select-stream-class ((s structure-class) in-p out-p char-p)
  (select-stream-class (class-prototype s) in-p out-p char-p))

(defmethod select-stream-class ((s standard-class) in-p out-p char-p)
  (select-stream-class (class-prototype s) in-p out-p char-p))


(defparameter *canonical-line-termination-conventions*
  '((:unix . nil)
    (:macos . :cr)
    (:cr . :cr)
    (:crlf . :crlf)
    (:cp/m . :crlf)
    (:msdos . :crlf)
    (:dos . :crlf)
    (:windows . :crlf)
    (:inferred . nil)
    (:unicode . :unicode)))


(defun optimal-buffer-size (fd)
  (or (nth-value 6 (%fstat fd)) *elements-per-buffer*))


;;; Note that we can get "bivalent" streams by specifiying :character-p t
;;; with a reasonable element-type (e.g. (UNSIGNED-BYTE 8))
(defun make-fd-stream (fd &key
                          (direction :input)
                          (interactive t)
                          (elements-per-buffer (optimal-buffer-size fd))
                          (element-type 'character)
                          (class 'fd-stream)
                          (sharing :private)
                          (character-p (or (eq element-type 'character)
                                           (subtypep element-type 'character)))
                          (basic nil)
                          encoding
                          line-termination
                          auto-close)
  (when line-termination
    (setq line-termination
          (cdr (assoc line-termination *canonical-line-termination-conventions*))))
  (when basic
    (setq class (map-to-basic-stream-class-name class))
    (setq basic (subtypep (find-class class) 'basic-stream)))
  (let* ((in-p (member direction '(:io :input)))
         (out-p (member direction '(:io :output)))
         (class-name (select-stream-class class in-p out-p character-p))
         (class (find-class class-name))
         (stream
          (make-ioblock-stream class
                               :insize (if in-p elements-per-buffer)
                               :outsize (if out-p elements-per-buffer)
                               :device fd
                               :interactive interactive
                               :element-type element-type
                               :advance-function (if in-p
                                                    (select-stream-advance-function class direction))
                               :listen-function (if in-p 'fd-stream-listen)
                               :eofp-function (if in-p 'fd-stream-eofp)
                               :force-output-function (if out-p
                                                         (select-stream-force-output-function class direction))
                               :close-function 'fd-stream-close
                               :sharing sharing
                               :character-p character-p
                               :encoding encoding
                               :line-termination line-termination)))
    (if auto-close
       (terminate-when-unreachable stream
                                   (lambda (stream)
                                     (close stream :abort t))))
    stream))

  
;;;  Fundamental streams.

(defclass fundamental-stream (stream)
    ())

(defclass fundamental-input-stream (fundamental-stream input-stream)
    ((shared-resource :initform nil :accessor input-stream-shared-resource)))

(defclass fundamental-output-stream (fundamental-stream output-stream)
    ())

(defmethod input-stream-p ((x t))
  (report-bad-arg x 'stream))
                           
(defmethod input-stream-p ((s input-stream))
  t)

(defmethod output-stream-p ((x t))
  (report-bad-arg x 'stream))

(defmethod output-stream-p ((s input-stream))
  (typep s 'output-stream))

(defmethod output-stream-p ((s output-stream))
  t)

(defmethod input-stream-p ((s output-stream))
  (typep s 'input-stream))

(defclass binary-stream (stream)
    ())

(defclass character-stream (stream)
    ())

(defmethod stream-external-format ((s character-stream))
  (make-external-format :character-encoding #+big-endian-target :utf32-be #+little-endian-target :utf32-le :line-termination :unix))


(defmethod (setf stream-external-format) (new (s character-stream))
  (check-type new 'external-format)
  (stream-external-format s))


(defclass fundamental-character-stream (fundamental-stream character-stream)
    ())

(defmethod stream-element-type ((s fundamental-character-stream))
  'character)

(defclass fundamental-binary-stream (fundamental-stream binary-stream)
    ())

(defclass character-input-stream (input-stream character-stream)
    ())

(defclass fundamental-character-input-stream (fundamental-input-stream
                                              fundamental-character-stream
                                              character-input-stream)
    ())

(defmethod stream-read-char-no-hang ((s fundamental-character-input-stream))
  (stream-read-char s))

(defmethod stream-peek-char ((s fundamental-character-input-stream))
  (let* ((ch (stream-read-char s)))
    (unless (eq ch :eof)
      (stream-unread-char s ch))
    ch))

(defmethod stream-listen ((s fundamental-character-input-stream))
  (let* ((ch (stream-read-char-no-hang s)))
    (when (and ch (not (eq ch :eof)))
      (stream-unread-char s ch))
    ch))

(defmethod stream-clear-input ((s fundamental-character-input-stream))
  )

(defmethod stream-read-line ((s character-input-stream))
  (generic-read-line s))

(defclass character-output-stream (output-stream character-stream)
    ())

(defclass fundamental-character-output-stream (fundamental-output-stream
                                               fundamental-character-stream
                                               character-output-stream)
    ())

(defclass binary-input-stream (input-stream binary-stream)
    ())

(defclass fundamental-binary-input-stream (fundamental-input-stream
                                           fundamental-binary-stream
                                           binary-input-stream)
    ())

(defclass binary-output-stream (output-stream binary-stream)
    ())

(defclass fundamental-binary-output-stream (fundamental-output-stream
                                            fundamental-binary-stream
                                            binary-output-stream)
    ())



(defmethod stream-read-byte ((s t))
  (report-bad-arg s '(and input-stream binary-stream)))

(defmethod stream-write-byte ((s t) b)
  (declare (ignore b))
  (report-bad-arg s '(and output-stream binary-stream)))

(defmethod stream-length ((s stream) &optional new)
  (declare (ignore new)))

(defmethod stream-start-line-p ((s character-output-stream))
  (eql 0 (stream-line-column s)))

(defmethod stream-terpri ((s character-output-stream))
  (stream-write-char s #\Newline))

(defmethod stream-fresh-line ((s character-output-stream))
  (unless (stream-start-line-p s)
    (stream-terpri s)
    t))

;;; The bad news is that this doesn't even bother to do the obvious
;;; (calling STREAM-WRITE-STRING with a longish string of spaces.)
;;; The good news is that this method is pretty useless to (format "~T" ...)
;;; anyhow.
(defmethod stream-advance-to-column ((s fundamental-character-output-stream)
                                     col)
  (generic-advance-to-column s col))

(defmethod stream-write-string ((stream fundamental-character-output-stream) string &optional (start 0) end)
  (generic-stream-write-string stream string start end))


;;; The read-/write-vector methods could be specialized for stream classes
;;; that expose the underlying buffering mechanism.
;;; They can assume that the 'vector' argument is a simple one-dimensional
;;; array and that the 'start' and 'end' arguments are sane.

(defmethod stream-write-vector ((stream character-output-stream)
                                vector start end)
  (declare (fixnum start end))
  (do* ((i start (1+ i)))
       ((= i end))
    (declare (fixnum i))
    (write-char (uvref vector i) stream)))

(defmethod stream-write-vector ((stream binary-output-stream)
                                vector start end)
  (declare (fixnum start end))
  (do* ((i start (1+ i)))
       ((= i end))
    (declare (fixnum i))
    (write-byte (uvref vector i) stream)))

(defmethod stream-read-vector ((stream character-input-stream)
                               vector start end)
  (generic-character-read-vector stream vector start end))


(defmethod stream-read-vector ((stream binary-input-stream)
                               vector start end)
  (declare (fixnum start end))
  (do* ((i start (1+ i)))
       ((= i end) end)
    (declare (fixnum i))
    (let* ((b (read-byte stream)))
      (if (eq b :eof)
        (return i)
        (setf (uvref vector i) b)))))




;;; File streams, in the abstract.

(defclass file-stream (stream)
    ())

(defmethod stream-domain ((s file-stream))
  :file)



;;; "Basic" (non-extensible) streams.


(declaim (inline basic-stream-p))

(defun basic-stream-p (x)
  (= (the fixnum (typecode x)) target::subtag-basic-stream))

(setf (type-predicate 'basic-stream) 'basic-stream-p)

(make-built-in-class 'basic-stream 'stream)
(make-built-in-class 'basic-file-stream 'basic-stream 'file-stream)
(make-built-in-class 'basic-character-stream 'basic-stream 'character-stream)
(make-built-in-class 'basic-binary-stream 'basic-stream 'binary-stream)

(make-built-in-class 'basic-input-stream 'basic-stream 'input-stream)
(make-built-in-class 'basic-output-stream 'basic-stream 'output-stream)
(make-built-in-class 'basic-io-stream 'basic-input-stream 'basic-output-stream)
(make-built-in-class 'basic-character-input-stream 'basic-input-stream 'basic-character-stream 'character-input-stream)
(make-built-in-class 'basic-character-output-stream 'basic-output-stream 'basic-character-stream 'character-output-stream)
(make-built-in-class 'basic-character-io-stream 'basic-character-input-stream 'basic-character-output-stream)
(make-built-in-class 'basic-binary-input-stream 'basic-input-stream 'basic-binary-stream 'binary-input-stream)
(make-built-in-class 'basic-binary-output-stream 'basic-output-stream 'basic-binary-stream 'binary-output-stream)
(make-built-in-class 'basic-binary-io-stream 'basic-binary-input-stream 'basic-binary-output-stream)


(defun %ioblock-external-format (ioblock)
  (let* ((encoding (or (ioblock-encoding ioblock)
                       (get-character-encoding nil)))
         (line-termination (or (ioblock-line-termination ioblock)
                               :unix)))
    (make-external-format :character-encoding (character-encoding-name encoding)
                          :line-termination line-termination)))

(defmethod input-stream-shared-resource ((s basic-input-stream))
  (getf (basic-stream.info s) :shared-resource))

(defmethod (setf input-stream-shared-resource) (new (s basic-input-stream))
  (setf (getf (basic-stream.info s) :shared-resource) new))

(defmethod print-object ((s basic-stream) out)
  (print-unreadable-object (s out :type t :identity t)
    (let* ((ioblock (basic-stream.state s))
           (fd (and ioblock (ioblock-device ioblock)))
           (encoding (and ioblock (encoding-name (ioblock-encoding ioblock)))))
      (if fd
        (format out "~a (~a/~d)" encoding (%unix-fd-kind fd) fd)
        (format out "~s" :closed)))))

(defmethod select-stream-class ((s (eql 'basic-stream)) in-p out-p char-p)
  (if char-p
    (if in-p
      (if out-p
        'basic-character-io-stream
        'basic-character-input-stream)
      'basic-character-output-stream)
    (if in-p
      (if out-p
        'basic-binary-io-stream
        'basic-binary-input-stream)
      'basic-binary-output-stream)))


(defmethod map-to-basic-stream-class-name (name)
  name)

(defmethod map-to-basic-stream-class-name ((name (eql 'fd-stream)))
  'basic-stream)

(defun allocate-basic-stream (class)
  (if (subtypep class 'basic-file-stream)
    (gvector :basic-stream class 0 nil nil nil nil nil)
    (gvector :basic-stream class 0 nil nil)))


(defmethod initialize-basic-stream ((s basic-stream) &key &allow-other-keys)
  )
  
(defmethod initialize-basic-stream :after  ((s basic-input-stream) &key &allow-other-keys)
  (setf (basic-stream.flags s)
        (logior (ash 1 basic-stream-flag.open-input) (basic-stream.flags s))))

(defmethod initialize-basic-stream :after ((s basic-output-stream) &key &allow-other-keys)
  (setf (basic-stream.flags s)
        (logior (ash 1 basic-stream-flag.open-output) (basic-stream.flags s))))

(defmethod initialize-basic-stream :after ((s basic-binary-stream) &key &allow-other-keys)
  (setf (basic-stream.flags s)
        (logior (ash 1 basic-stream-flag.open-binary) (basic-stream.flags s))))

(defmethod initialize-basic-stream :after ((s basic-character-stream) &key &allow-other-keys)
  (setf (basic-stream.flags s)
        (logior (ash 1 basic-stream-flag.open-character) (basic-stream.flags s))))

(defun make-basic-stream-instance (class &rest initargs)
  (let* ((s (allocate-basic-stream class)))
    (apply #'initialize-basic-stream s initargs)
    s))



(defmethod (setf stream-ioblock) (ioblock (s basic-stream))
  (setf (basic-stream.state s) ioblock))

(defmethod stream-create-ioblock ((stream basic-stream) &rest args &key)
  (declare (dynamic-extent args))
  (apply #'make-ioblock :stream stream args))


(defmethod stream-write-list ((stream fundamental-character-output-stream)
                              list count)
  (declare (fixnum count))
  (dotimes (i count)
    (stream-write-char stream (pop list))))

(defmethod stream-write-list ((stream basic-character-output-stream)
                              list count)
  (declare (fixnum count))
  (dotimes (i count)
    (stream-write-char stream (pop list))))

(defmethod stream-read-list ((stream character-input-stream)
                             list count)
  (generic-character-read-list stream list count))


(defmethod stream-write-list ((stream fundamental-binary-output-stream)
                              list count)
  (declare (fixnum count))
  (dotimes (i count)
    (let* ((element (pop list)))
      (if (typep element 'character)
        (write-char element stream)
        (write-byte element stream)))))

(defmethod stream-write-list ((stream basic-binary-output-stream)
                              list count)
  (declare (fixnum count))
  (dotimes (i count)
    (let* ((element (pop list)))
      (if (typep element 'character)
        (write-char element stream)
        (write-byte element stream)))))

(defmethod stream-read-list ((stream binary-input-stream)
                             list count)
  (declare (fixnum count))
  (do* ((tail list (cdr tail))
        (i 0 (1+ i)))
       ((= i count) count)
    (declare (fixnum i))
    (let* ((b (read-byte stream)))
      (if (eq b :eof)
        (return i)
        (rplaca tail b)))))





(defmethod stream-read-vector ((stream binary-input-stream)
                               vector start end)
  (declare (fixnum start end))
  (do* ((i start (1+ i)))
       ((= i end) end)
    (declare (fixnum i))
    (let* ((b (read-byte stream)))
      (if (eq b :eof)
        (return i)
        (setf (uvref vector i) b)))))

(defun stream-is-closed (s)
  (error "~s is closed" s))

(defmethod stream-read-char ((s basic-character-input-stream))
  (let* ((ioblock (basic-stream-ioblock s)))
    (funcall (ioblock-read-char-function ioblock) ioblock)))


(defmethod stream-read-char-no-hang ((stream basic-character-input-stream))
  (let* ((ioblock (basic-stream-ioblock stream)))
    (with-ioblock-input-locked (ioblock)
      (values
          (%ioblock-tyi-no-hang ioblock)))))
       
(defmethod stream-peek-char ((stream basic-character-input-stream))
  (let* ((ioblock (basic-stream-ioblock stream)))
    (with-ioblock-input-locked (ioblock)
      (values
       (funcall (ioblock-peek-char-function ioblock) ioblock)))))

(defmethod stream-clear-input ((stream basic-character-input-stream))
  (let* ((ioblock (basic-stream-ioblock stream)))
    (with-ioblock-input-locked (ioblock)
      (values
        (%ioblock-clear-input ioblock)))))

(defmethod stream-unread-char ((s basic-character-input-stream) char)
  (let* ((ioblock (basic-stream-ioblock s)))
    (with-ioblock-input-locked (ioblock)
      (values
       (funcall (ioblock-unread-char-function ioblock) ioblock char)))))

(defmethod stream-read-ivector ((s basic-binary-input-stream)
                                iv start nb)
  (let* ((ioblock (basic-stream-ioblock s)))
    (with-ioblock-input-locked (ioblock)
      (values
       (%ioblock-binary-in-ivect ioblock iv start nb)))))

(defmethod stream-read-vector ((stream basic-character-input-stream)
                               vector start end)
  (declare (fixnum start end))
  (if (not (typep vector 'simple-base-string))
    (generic-character-read-vector stream vector start end)
    (let* ((ioblock (basic-stream-ioblock stream)))
      (with-ioblock-input-locked (ioblock)
        (values
         (funcall (ioblock-character-read-vector-function ioblock)
                  ioblock vector start end))))))

(defmethod stream-read-line ((stream basic-character-input-stream))
  (let* ((ioblock (basic-stream-ioblock stream)))
    (with-ioblock-input-locked (ioblock)
      (funcall (ioblock-read-line-function ioblock) ioblock))))

                             
;;; Synonym streams.

(defclass synonym-stream (fundamental-stream)
    ((symbol :initarg :symbol :reader synonym-stream-symbol)))

(defmethod print-object ((s synonym-stream) out)
  (print-unreadable-object (s out :type t :identity t)
    (format out "to ~s" (synonym-stream-symbol s))))

(macrolet ((synonym-method (name &rest args)
            (let* ((stream (make-symbol "STREAM")))
              `(defmethod ,name ((,stream synonym-stream) ,@args)
                (,name (symbol-value (synonym-stream-symbol ,stream)) ,@args)))))
           (synonym-method stream-read-char)
           (synonym-method stream-read-byte)
           (synonym-method stream-unread-char c)
           (synonym-method stream-read-char-no-hang)
           (synonym-method stream-peek-char)
           (synonym-method stream-listen)
           (synonym-method stream-eofp)
           (synonym-method stream-clear-input)
           (synonym-method stream-read-line)
           (synonym-method stream-read-list l c)
           (synonym-method stream-read-vector v start end)
           (synonym-method stream-write-char c)
           ;(synonym-method stream-write-string str &optional (start 0) end)
           (synonym-method stream-write-byte b)
           (synonym-method stream-clear-output)
           (synonym-method stream-line-column)
           (synonym-method stream-set-column new)
           (synonym-method stream-advance-to-column new)
           (synonym-method stream-start-line-p)
           (synonym-method stream-fresh-line)
           (synonym-method stream-terpri)
           (synonym-method stream-force-output)
           (synonym-method stream-finish-output)
           (synonym-method stream-write-list l c)
           (synonym-method stream-write-vector v start end)
           (synonym-method stream-element-type)
           (synonym-method input-stream-p)
           (synonym-method output-stream-p)
           (synonym-method interactive-stream-p)
           (synonym-method stream-direction)
           (synonym-method stream-device direction)
           (synonym-method stream-surrounding-characters))


(defmethod stream-write-string ((s synonym-stream) string &optional (start 0) end)
  (stream-write-string (symbol-value (synonym-stream-symbol s)) string start end))

(defmethod stream-length ((s synonym-stream) &optional new)
  (stream-length (symbol-value (synonym-stream-symbol s)) new))

(defmethod stream-position ((s synonym-stream) &optional new)
  (stream-position (symbol-value (synonym-stream-symbol s)) new))

(defun make-synonym-stream (symbol)
  (make-instance 'synonym-stream :symbol (require-type symbol 'symbol)))

;;;
(defclass composite-stream-mixin ()
    ((open-p :initform t)))

(defmethod close :after ((stream composite-stream-mixin) &key abort)
  (declare (ignore abort))
  (with-slots (open-p) stream
    (setq open-p nil)))

(defmethod open-stream-p ((stream composite-stream-mixin))
  (slot-value stream 'open-p))


;;; Two-way streams.
(defclass two-way-stream (composite-stream-mixin fundamental-input-stream fundamental-output-stream)
    ((input-stream :initarg :input-stream :accessor two-way-stream-input-stream)
     (output-stream :initarg :output-stream :accessor two-way-stream-output-stream)))

(defmethod print-object ((s two-way-stream) out)
  (print-unreadable-object (s out :type t :identity t)
    (format out "input ~s, output ~s" 
            (two-way-stream-input-stream s)
            (two-way-stream-output-stream s))))

(macrolet ((two-way-input-method (name &rest args)
             (let* ((stream (make-symbol "STREAM")))
               `(defmethod ,name ((,stream two-way-stream) ,@args)
                 (,name (two-way-stream-input-stream ,stream) ,@args))))
           (two-way-output-method (name &rest args)
             (let* ((stream (make-symbol "STREAM")))
               `(defmethod ,name ((,stream two-way-stream) ,@args)
                 (,name (two-way-stream-output-stream ,stream) ,@args)))))
  (two-way-input-method stream-read-char)
  (two-way-input-method stream-read-byte)
  (two-way-input-method stream-unread-char c)
  (two-way-input-method stream-read-char-no-hang)
  (two-way-input-method stream-peek-char)
  (two-way-input-method stream-listen)
  (two-way-input-method stream-eofp)
  (two-way-input-method stream-clear-input)
  (two-way-input-method stream-read-line)
  (two-way-input-method stream-read-list l c)
  (two-way-input-method stream-read-vector v start end)
  (two-way-input-method stream-surrounding-characters)
  (two-way-output-method stream-write-char c)
  (two-way-output-method stream-write-byte b)
  (two-way-output-method stream-clear-output)
  (two-way-output-method stream-line-column)
  (two-way-output-method stream-set-column new)
  (two-way-output-method stream-advance-to-column new)
  (two-way-output-method stream-start-line-p)
  (two-way-output-method stream-fresh-line)
  (two-way-output-method stream-terpri)
  (two-way-output-method stream-force-output)
  (two-way-output-method stream-finish-output)
  (two-way-output-method stream-write-list l c)
  (two-way-output-method stream-write-vector v start end))

(defmethod stream-device ((s two-way-stream) direction)
  (case direction
    (:input (stream-device (two-way-stream-input-stream s) direction))
    (:output (stream-device (two-way-stream-output-stream s) direction))))
    
(defmethod stream-write-string ((s two-way-stream) string &optional (start 0) end)
  (stream-write-string (two-way-stream-output-stream s) string start end))

(defmethod stream-element-type ((s two-way-stream))
  (let* ((in-type (stream-element-type (two-way-stream-input-stream s)))
         (out-type (stream-element-type (two-way-stream-output-stream s))))
    (if (equal in-type out-type)
      in-type
      `(and ,in-type ,out-type))))

(defun make-two-way-stream (in out)
  "Return a bidirectional stream which gets its input from INPUT-STREAM and
   sends its output to OUTPUT-STREAM."
  (unless (input-stream-p in)
    (require-type in 'input-stream))
  (unless (output-stream-p out)
    (require-type out 'output-stream))
  (make-instance 'two-way-stream :input-stream in :output-stream out))

;;; This is intended for use with things like *TERMINAL-IO*, where the
;;; OS echoes interactive input.  Whenever we read a character from
;;; the underlying input-stream of such a stream, we need to update
;;; our notion of the underlying output-stream's STREAM-LINE-COLUMN.

(defclass echoing-two-way-stream (two-way-stream)
    ())

(defmethod stream-read-char ((s echoing-two-way-stream))
  (let* ((out (two-way-stream-output-stream s))
         (in (two-way-stream-input-stream s)))
    (force-output out)
    (let* ((ch (stream-read-char in)))
      (unless (eq ch :eof)
        (if (eq ch #\newline)
          (stream-set-column out 0)
          (let* ((cur (stream-line-column out)))
            (when cur
              (stream-set-column out (1+ (the fixnum cur)))))))
      ch)))

(defmethod stream-read-line ((s echoing-two-way-stream))
  (let* ((out (two-way-stream-output-stream s)))
    (multiple-value-bind (string eof)
        (call-next-method)
      (unless eof
        (stream-set-column out 0))
      (values string eof))))

(defun make-echoing-two-way-stream (in out)
  (make-instance 'echoing-two-way-stream :input-stream in :output-stream out))

;;;echo streams

(defclass echo-stream (two-way-stream)
    ((did-untyi :initform nil)))

(defmethod echo-stream-input-stream ((s echo-stream))
  (two-way-stream-input-stream s))

(defmethod echo-stream-output-stream ((s echo-stream))
  (two-way-stream-output-stream s))

(defmethod stream-read-char ((s echo-stream))
  (let* ((char (stream-read-char (echo-stream-input-stream s))))
    (unless (eq char :eof)
      (if (slot-value s 'did-untyi)
        (setf (slot-value s 'did-untyi) nil)
        (stream-write-char (echo-stream-output-stream s) char)))
    char))

(defmethod stream-unread-char ((s echo-stream) c)
  (call-next-method s c)
  (setf (slot-value s 'did-untyi) c))

(defmethod stream-read-char-no-hang ((s echo-stream))
  (let* ((char (stream-read-char-no-hang (echo-stream-input-stream s))))
    (unless (eq char :eof)
      (if (slot-value s 'did-untyi)
        (setf (slot-value s 'did-untyi) nil)
        (stream-write-char (echo-stream-output-stream s) char)))
    char))

(defmethod stream-clear-input ((s echo-stream))
  (call-next-method)
  (setf (slot-value s 'did-untyi) nil))

(defmethod stream-read-byte ((s echo-stream))
  (let* ((byte (stream-read-byte (echo-stream-input-stream s))))
    (unless (eq byte :eof)
      (stream-write-byte (echo-stream-output-stream s) byte))
    byte))

(defmethod stream-read-line ((s echo-stream))
  (generic-read-line s))

(defmethod stream-read-vector ((s echo-stream) vector start end)
  (if (subtypep (stream-element-type s) 'character)
      (generic-character-read-vector s vector start end)
    (generic-binary-read-vector s vector start end)))

(defun make-echo-stream (input-stream output-stream)
  "Return a bidirectional stream which gets its input from INPUT-STREAM and
   sends its output to OUTPUT-STREAM. In addition, all input is echoed to
   the output stream."
  (make-instance 'echo-stream
                 :input-stream input-stream
                 :output-stream output-stream))

;;;concatenated-streams

(defclass concatenated-stream (composite-stream-mixin fundamental-input-stream)
    ((streams :initarg :streams :accessor concatenated-stream-streams)))


(defun concatenated-stream-current-input-stream (s)
  (car (concatenated-stream-streams s)))

(defun concatenated-stream-next-input-stream (s)
  (setf (concatenated-stream-streams s)
        (cdr (concatenated-stream-streams s)))
  (concatenated-stream-current-input-stream s))

(defmethod stream-element-type ((s concatenated-stream))
  (let* ((c (concatenated-stream-current-input-stream s)))
    (if c
      (stream-element-type c)
      nil)))



(defmethod stream-read-char ((s concatenated-stream))
  (do* ((c (concatenated-stream-current-input-stream s)
           (concatenated-stream-next-input-stream s)))
       ((null c) :eof)
    (let* ((ch (stream-read-char c)))
      (unless (eq ch :eof)
        (return ch)))))

(defmethod stream-read-char-no-hang ((s concatenated-stream))
  (do* ((c (concatenated-stream-current-input-stream s)
           (concatenated-stream-next-input-stream s)))
       ((null c) :eof)
    (let* ((ch (stream-read-char-no-hang c)))
      (unless (eq ch :eof)
        (return ch)))))

(defmethod stream-read-byte ((s concatenated-stream))
  (do* ((c (concatenated-stream-current-input-stream s)
           (concatenated-stream-next-input-stream s)))
       ((null c) :eof)
    (let* ((b (stream-read-byte c)))
      (unless (eq b :eof)
        (return b)))))

(defmethod stream-peek-char ((s concatenated-stream))
  (do* ((c (concatenated-stream-current-input-stream s)
       (concatenated-stream-next-input-stream s)))
       ((null c) :eof)
    (let* ((ch (stream-peek-char c)))
      (unless (eq ch :eof)
        (return ch)))))

(defmethod stream-read-line ((s concatenated-stream))
  (generic-read-line s))

(defmethod stream-read-list ((s concatenated-stream) list count)
  (generic-character-read-list s list count))

(defmethod stream-read-vector ((s concatenated-stream) vector start end)
  (if (subtypep (stream-element-type s) 'character)
      (generic-character-read-vector s vector start end)
    (generic-binary-read-vector s vector start end)))

(defmethod stream-unread-char ((s concatenated-stream) char)
  (let* ((c (concatenated-stream-current-input-stream s)))
    (if c
      (stream-unread-char c char))))

(defmethod stream-listen ((s concatenated-stream))
  (do* ((c (concatenated-stream-current-input-stream s)
           (concatenated-stream-next-input-stream s)))
       ((null c))
    (when (stream-listen c)
      (return t))))

(defmethod stream-eofp ((s concatenated-stream))
  (do* ((c (concatenated-stream-current-input-stream s)
           (concatenated-stream-next-input-stream s)))
       ((null c) t)
    (when (stream-listen c)
      (return nil))))

(defmethod stream-clear-input ((s concatenated-stream))
  (let* ((c (concatenated-stream-current-input-stream s)))
    (when c (stream-clear-input c))))


(defun make-concatenated-stream (&rest streams)
  "Return a stream which takes its input from each of the streams in turn,
   going on to the next at EOF."
  (dolist (s streams (make-instance 'concatenated-stream :streams streams))
    (unless (input-stream-p s)
      (error "~S is not an input stream" s))))

;;;broadcast-streams



(defclass broadcast-stream (fundamental-output-stream)
    ((streams :initarg :streams :reader broadcast-stream-streams)))

(macrolet ((broadcast-method
               (op (stream &rest others )
                   &optional
                   (args (cons stream others)))
             (let* ((sub (gensym))
                    (result (gensym)))
               `(defmethod ,op ((,stream broadcast-stream) ,@others)
                 (let* ((,result nil))
                   (dolist (,sub (broadcast-stream-streams ,stream) ,result)
                             (setq ,result (,op ,@(cons sub (cdr args))))))))))
             (broadcast-method stream-write-char (s c))
             (broadcast-method stream-write-string
                                      (s str &optional (start 0) end)
                                      (s str start end))
             (broadcast-method stream-write-byte (s b))
             (broadcast-method stream-clear-output (s))
             (broadcast-method stream-line-column (s))
             (broadcast-method stream-set-column (s new))
             (broadcast-method stream-advance-to-column (s new))
             (broadcast-method stream-start-line-p (s))
             (broadcast-method stream-terpri (s))
             (broadcast-method stream-force-output (s))
             (broadcast-method stream-finish-output (s))
             (broadcast-method stream-stream-write-list (s l c))
             (broadcast-method stream-write-vector (s v start end)))

(defun last-broadcast-stream (s)
  (car (last (broadcast-stream-streams s))))

(defmethod stream-fresh-line ((s broadcast-stream))
  (let* ((did-output-newline nil))
    (dolist (sub (broadcast-stream-streams s) did-output-newline)
      (setq did-output-newline (stream-fresh-line sub)))))

(defmethod stream-element-type ((s broadcast-stream))
  (let* ((last (last-broadcast-stream s)))
    (if last
      (stream-element-type last)
      t)))

(defmethod stream-length ((s broadcast-stream) &optional new)
  (unless new
    (let* ((last (last-broadcast-stream s)))
      (if last
        (stream-length last)
        0))))

(defmethod stream-position ((s broadcast-stream) &optional new)
  (unless new
    (let* ((last (last-broadcast-stream s)))
      (if last
        (stream-position last)
        0))))

(defun make-broadcast-stream (&rest streams)
  (dolist (s streams (make-instance 'broadcast-stream :streams streams))
    (unless (output-stream-p s)
      (error "~s is not an output stream." s))))



;;; String streams.
(make-built-in-class 'string-stream 'basic-character-stream)

(defmethod print-object ((s string-stream) out)
  (print-unreadable-object (s out :type t :identity t)
    (unless (open-stream-p s)  (format out " ~s" :closed))))


                 

(defstruct (string-stream-ioblock (:include ioblock))
  string)

(defstruct (string-output-stream-ioblock (:include string-stream-ioblock))
  (index 0))

(defstatic *string-output-stream-class* (make-built-in-class 'string-output-stream 'string-stream 'basic-character-output-stream))

(defstatic *fill-pointer-string-output-stream-class* (make-built-in-class 'fill-pointer-string-output-stream 'string-output-stream))

(def-standard-initial-binding %string-output-stream-ioblocks% (%cons-pool nil))

(defmethod stream-force-output ((s string-output-stream))
  nil)

(defmethod stream-finish-output ((s string-output-stream))
  nil)

(defmethod stream-clear-output ((s string-output-stream))
  nil)

;;; Should only be used for a stream whose class is exactly
;;; *string-output-stream-class* 
(defun %close-string-output-stream (stream ioblock)
  (when (eq (basic-stream.class stream)
            *string-output-stream-class*)
    (without-interrupts
     (setf (ioblock-stream ioblock) (pool.data %string-output-stream-ioblocks%)
           (pool.data %string-output-stream-ioblocks%) ioblock))))

(defun create-string-output-stream-ioblock (&rest keys &key stream &allow-other-keys)
  (declare (dynamic-extent keys))
  (let* ((recycled (and stream
                        (eq (basic-stream.class stream)
                            *string-output-stream-class*)
                        (without-interrupts
                         (let* ((data (pool.data %string-output-stream-ioblocks%)))
                           (when data
                             (setf (pool.data %string-output-stream-ioblocks%)
                                   (ioblock-stream data)
                                   (ioblock-stream data) stream
                                   (ioblock-charpos data) 0
                                   (string-output-stream-ioblock-index data) 0))
                           data)))))
    (or recycled (apply #'make-string-output-stream-ioblock keys))))
                        


(defun %%make-string-output-stream (class string write-char-function write-string-function)
  (let* ((stream (allocate-basic-stream class)))
    (initialize-basic-stream stream :element-type 'character)
    (let* ((ioblock (create-string-output-stream-ioblock
                     :stream stream
                     :device nil
                     :string string
                     :element-type 'character
                     :write-char-function write-char-function
                     :write-char-when-locked-function write-char-function
                     :write-simple-string-function write-string-function
                     :force-output-function #'false
                     :close-function #'%close-string-output-stream)))
      (setf (basic-stream.state stream) ioblock)
      stream)))

(declaim (inline %string-push-extend))
(defun %string-push-extend (char string)
  (let* ((fill (%svref string target::vectorH.logsize-cell))
         (size (%svref string target::vectorH.physsize-cell)))
    (declare (fixnum fill size))
    (if (< fill size)
      (multiple-value-bind (data offset) (array-data-and-offset string)
        (declare (simple-string data) (fixnum offset))
        (setf (schar data (the fixnum (+ offset fill))) char
              (%svref string target::vectorH.logsize-cell) (the fixnum (1+ fill))))
      (vector-push-extend char string))))
              

(defun fill-pointer-string-output-stream-ioblock-write-char (ioblock char)
  ;; can do better (maybe much better) than VECTOR-PUSH-EXTEND here.
  (if (eql char #\Newline)
    (setf (ioblock-charpos ioblock) 0)
    (incf (ioblock-charpos ioblock)))
  (%string-push-extend char (string-stream-ioblock-string ioblock)))

(defmethod stream-force-output ((stream string-output-stream)) nil)

(defun fill-pointer-string-output-stream-ioblock-write-simple-string (ioblock string start-char num-chars)
  (let* ((end (+ start-char num-chars))
         (nlpos (position #\Newline string :start start-char :end end :from-end t)))
    (if nlpos
      (setf (ioblock-charpos ioblock) (- end nlpos))
      (incf (ioblock-charpos ioblock) num-chars))
    (let* ((out (string-stream-ioblock-string ioblock)))
      (do* ((n 0 (1+ n))
            (i start-char (1+ i)))
           ((= n num-chars) num-chars)
        (%string-push-extend (schar string i) out)))))

(defmethod stream-position ((s fill-pointer-string-output-stream) &optional newpos)
  (let* ((string (string-stream-string s)))
    (if newpos
      (setf (fill-pointer string) newpos)
      (fill-pointer string))))

;;; If the stream's string is adjustable, it doesn't really have a meaningful
;;; "maximum size".
(defmethod stream-length ((s string-output-stream) &optional newlen)
  (unless newlen
    (array-total-size (string-stream-string s))))

;;; This creates a FILL-POINTER-STRING-OUTPUT-STREAM.
(defun %make-string-output-stream (string)
  (unless (and (typep string 'string)
               (array-has-fill-pointer-p string))
    (error "~S must be a string with a fill pointer."))
  (%%make-string-output-stream *fill-pointer-string-output-stream-class* string 'fill-pointer-string-output-stream-ioblock-write-char 'fill-pointer-string-output-stream-ioblock-write-simple-string))

(defun string-output-stream-ioblock-write-char (ioblock char)
  (let* ((string (string-output-stream-ioblock-string ioblock))
         (index (string-output-stream-ioblock-index ioblock))
         (len (length string)))
    (declare (simple-string string)
             (fixnum index len))
  (if (eql char #\Newline)
    (setf (ioblock-charpos ioblock) 0)
    (incf (ioblock-charpos ioblock)))
  (if (= index len)
      (let* ((newlen (+ len len))      ;non-zero !
             (new (make-string newlen)))
        (%copy-ivector-to-ivector string 0 new 0 (the fixnum (ash len 2)))
        (setq string new)
        (setf (string-output-stream-ioblock-string ioblock) new)))
    (setf (string-output-stream-ioblock-index ioblock) (the fixnum (1+ index))
          (schar string index) char)))

(defun string-output-stream-ioblock-write-simple-string (ioblock string start-char num-chars)
  (declare (simple-string string)
           (fixnum start-char num-chars)
           (optimize (speed 3) (safety 0)))
  (let* ((out (string-output-stream-ioblock-string ioblock))
         (index (string-output-stream-ioblock-index ioblock))
         (len (length out))
         (need (+ index num-chars)))
    (declare (simple-string out)
             (fixnum index len need))
    (if (< len need)
      (let* ((newlen (+ need need))
             (new (make-string newlen)))
        (declare (fixnum newlen) (simple-string new))
        (dotimes (i len)
          (setf (schar new i) (schar out i)))
        (setq out new)
        (setf (string-output-stream-ioblock-string ioblock) new)))
    (do* ((src start-char (1+ src))
          (dest index (1+ dest))
          (nlpos nil)
          (end (+ start-char num-chars)))
         ((= src end)
          (setf (string-output-stream-ioblock-index ioblock) need)
          (if nlpos
            (setf (ioblock-charpos ioblock) (the fixnum (- end (the fixnum nlpos))))
            (incf (ioblock-charpos ioblock) num-chars))
          num-chars)
      (let* ((char (schar string src)))
        (if (eql char #\Newline)
          (setq nlpos src))
        (setf (schar out dest) char)))))


(defmethod stream-position ((stream string-output-stream) &optional newpos)
  (let* ((ioblock (basic-stream-ioblock stream)))
    (if (null newpos)
      (string-output-stream-ioblock-index ioblock)
      (if (and (typep newpos 'fixnum)
               (>= (the fixnum newpos) 0)
               (<= (the fixnum newpos) (length (string-output-stream-ioblock-string ioblock))))
        (setf (string-output-stream-ioblock-index ioblock) newpos)))))

(defun make-simple-string-output-stream ()
  (%%make-string-output-stream *string-output-stream-class*
                               (make-string 40)
                               'string-output-stream-ioblock-write-char
                               'string-output-stream-ioblock-write-simple-string))

(defun make-string-output-stream (&key (element-type 'character element-type-p))
  "Return an output stream which will accumulate all output given it for
   the benefit of the function GET-OUTPUT-STREAM-STRING."
  (when (and element-type-p
             (not (member element-type '(base-character character
                                         standard-char))))
    (unless (subtypep element-type 'character)
      (error "~S argument ~S is not a subtype of ~S."
             :element-type element-type 'character)))
  (make-simple-string-output-stream))


;;;"Bounded" string output streams.
(defstatic *truncating-string-output-stream-class* (make-built-in-class 'truncating-string-stream 'string-output-stream))

(defun truncating-string-output-stream-ioblock-write-char (ioblock char)
  (let* ((stream (ioblock-stream ioblock))
         (string (string-output-stream-ioblock-string ioblock))
         (index (string-output-stream-ioblock-index ioblock)))
    (declare (fixnum index) (simple-string string))
    (if (< index (the fixnum (length string)))
      (progn
        (setf (schar string index) char
              (string-output-stream-ioblock-index ioblock) (the fixnum (1+ index)))
        (if (eql char #\Newline)
          (setf (ioblock-charpos ioblock) 0)
          (incf (ioblock-charpos ioblock))))
      (setf (getf (basic-stream.info stream) :truncated) t))))

(defun truncating-string-output-stream-ioblock-write-simple-string (ioblock string start-char num-chars)
  (let* ((stream (ioblock-stream ioblock)))
  (do* ((n 0 (1+ n))
        (i start-char (1+ i)))
       ((= n num-chars) num-chars)
    (truncating-string-output-stream-ioblock-write-char ioblock (schar string i))
    (if (getf (basic-stream.info stream) :truncated)
      (return n)))))

(defun truncating-string-output-stream-truncated-p (stream)
  (getf (basic-stream.info stream) :truncated))

(defun make-truncating-string-stream (len)
  (%%make-string-output-stream *truncating-string-output-stream-class*
                               (make-array len
                                     :element-type 'character
                                     :fill-pointer 0
                                     :adjustable nil)
                               'truncating-string-output-stream-ioblock-write-char
                               'truncating-string-output-stream-ioblock-write-simple-string))
                               

;;;One way to indent on newlines:

(defstatic *indenting-string-output-stream-class* (make-built-in-class 'indenting-string-output-stream 'string-output-stream))



(defun indenting-string-stream-ioblock-write-char (ioblock c)
  (string-output-stream-ioblock-write-char ioblock c)
  (if (eql c #\newline)
    (let* ((stream (ioblock-stream ioblock))
           (info (basic-stream.info stream))
           (indent (getf info 'indent))
           (prefixlen 0)
           (prefixchar (getf info 'prefixchar)))
      (when prefixchar
        (if (typep prefixchar 'character)
          (progn
            (setq prefixlen 1)
            (string-output-stream-ioblock-write-char ioblock prefixchar))
          (dotimes (i (setq prefixlen (length prefixchar)))
            (string-output-stream-ioblock-write-char ioblock (schar prefixchar i)))))
      (when indent
        (dotimes (i (the fixnum (- indent prefixlen)))
          (string-output-stream-ioblock-write-char ioblock #\Space)))))
  c)

(defun indenting-string-stream-ioblock-write-simple-string (ioblock string start-char num-chars)
  (do* ((n 0 (1+ n))
        (i start-char (1+ i)))
       ((= n num-chars) num-chars)
    (indenting-string-stream-ioblock-write-char ioblock (schar string i))))

(defun make-indenting-string-output-stream (prefixchar indent)
  (let* ((stream (%%make-string-output-stream
                   *indenting-string-output-stream-class*
                  (make-string 10)
                  'indenting-string-stream-ioblock-write-char
                  'indenting-string-stream-ioblock-write-simple-string)))
    (setf (getf (basic-stream.info stream) 'indent) indent
          (getf (basic-stream.info stream) 'prefixchar) prefixchar)
    stream))

(defun (setf indenting-string-output-stream-indent) (new stream)
  (if (and (typep stream 'basic-stream)
           (eq (basic-stream.class stream) *indenting-string-output-stream-class*))
    (setf (getf (basic-stream.info stream) 'indent) new)
    (report-bad-arg stream 'indenting-string-output-stream)))


(defun get-output-stream-string (s)
  (let* ((class (if (typep s 'basic-stream) (basic-stream.class s))))
    (or (eq class *string-output-stream-class*)
        (eq class *truncating-string-output-stream-class*)
        (eq class *indenting-string-output-stream-class*)
        (eq class *fill-pointer-string-output-stream-class*)
        (report-bad-arg s 'string-output-stream))
    (let* ((ioblock (basic-stream-ioblock s))
           (string (string-stream-ioblock-string ioblock)))
      (if (eq class *fill-pointer-string-output-stream-class*)
        (prog1 (ensure-simple-string string)
          (setf (fill-pointer string) 0))
        (let* ((index (string-output-stream-ioblock-index ioblock))
               (result (make-string index)))
          (declare (fixnum index))
          (%copy-ivector-to-ivector string 0 result 0 (the fixnum (