  streams for UNIX file descriptors

  This software is part of the SBCL system . See the README file for
;;;; more information.
;;;;
  This software is derived from the CMU CL system , which was
  written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB!IMPL")

  BUFFER
;;;;
  Streams hold BUFFER objects , which contain a SAP , size of the
  memory area the SAP stands for ( LENGTH bytes ) , and HEAD and TAIL
;;;; indexes which delimit the "valid", or "active" area of the
  memory . HEAD is inclusive , TAIL is exclusive .
;;;;
;;;; Buffers get allocated lazily, and are recycled by returning them
;;;; to the *AVAILABLE-BUFFERS* list. Every buffer has it's own
  finalizer , to take care of releasing the SAP memory when a stream
;;;; is not properly closed.
;;;;
;;;; The code aims to provide a limited form of thread and interrupt
;;;; safety: parallel writes and reads may lose output or input, cause
  interleaved IO , etc -- but they should not corrupt memory . The
;;;; key to doing this is to read buffer state once, and update the
;;;; state based on the read state:
;;;;
;;;; (let ((tail (buffer-tail buffer)))
;;;;   ...
    ( setf ( buffer - tail buffer ) ( + tail n ) ) )
;;;;
;;;; NOT
;;;;
;;;; (let ((tail (buffer-tail buffer)))
;;;;   ...
;;;;  (incf (buffer-tail buffer) n))
;;;;

(declaim (inline buffer-sap buffer-length buffer-head buffer-tail
                 (setf buffer-head) (setf buffer-tail)))
(defstruct (buffer (:constructor %make-buffer (sap length)))
  (sap (missing-arg) :type system-area-pointer :read-only t)
  (length (missing-arg) :type index :read-only t)
  (head 0 :type index)
  (tail 0 :type index))

(defvar *available-buffers* ()
  #!+sb-doc
  "List of available buffers.")

(defvar *available-buffers-lock* (sb!thread:make-mutex
                                  :name "lock for *AVAILABLE-BUFFERS*")
  #!+sb-doc
  "Mutex for access to *AVAILABLE-BUFFERS*.")

(defmacro with-available-buffers-lock ((&optional) &body body)
  ;; CALL-WITH-SYSTEM-MUTEX because streams are low-level enough to be
  ;; async signal safe, and in particular a C-c that brings up the
  ;; debugger while holding the mutex would lose badly.
  `(sb!thread::with-system-mutex (*available-buffers-lock*)
     ,@body))

(defconstant +bytes-per-buffer+ (* 4 1024)
  #!+sb-doc
  "Default number of bytes per buffer.")

(defun alloc-buffer (&optional (size +bytes-per-buffer+))
  ;; Don't want to allocate & unwind before the finalizer is in place.
  (without-interrupts
    (let* ((sap (allocate-system-memory size))
           (buffer (%make-buffer sap size)))
      (when (zerop (sap-int sap))
        (error "Could not allocate ~D bytes for buffer." size))
      (finalize buffer (lambda ()
                         (deallocate-system-memory sap size))
                :dont-save t)
      buffer)))

(defun get-buffer ()
  ;; Don't go for the lock if there is nothing to be had -- sure,
  another thread might just release one before we get it , but that
  ;; is not worth the cost of locking. Also release the lock before
  ;; allocation, since it's going to take a while.
  (if *available-buffers*
      (or (with-available-buffers-lock ()
            (pop *available-buffers*))
          (alloc-buffer))
      (alloc-buffer)))

(declaim (inline reset-buffer))
(defun reset-buffer (buffer)
  (setf (buffer-head buffer) 0
        (buffer-tail buffer) 0)
  buffer)

(defun release-buffer (buffer)
  (reset-buffer buffer)
  (with-available-buffers-lock ()
    (push buffer *available-buffers*)))

;;; This is a separate buffer management function, as it wants to be
;;; clever about locking -- grabbing the lock just once.
(defun release-fd-stream-buffers (fd-stream)
  (let ((ibuf (fd-stream-ibuf fd-stream))
        (obuf (fd-stream-obuf fd-stream))
        (queue (loop for item in (fd-stream-output-queue fd-stream)
                       when (buffer-p item)
                       collect (reset-buffer item))))
    (when ibuf
      (push (reset-buffer ibuf) queue))
    (when obuf
      (push (reset-buffer obuf) queue))
    ;; ...so, anything found?
    (when queue
      ;; detach from stream
      (setf (fd-stream-ibuf fd-stream) nil
            (fd-stream-obuf fd-stream) nil
            (fd-stream-output-queue fd-stream) nil)
      ;; splice to *available-buffers*
      (with-available-buffers-lock ()
        (setf *available-buffers* (nconc queue *available-buffers*))))))

  the FD - STREAM structure

(defstruct (fd-stream
            (:constructor %make-fd-stream)
            (:conc-name fd-stream-)
            (:predicate fd-stream-p)
            (:include ansi-stream
                      (misc #'fd-stream-misc-routine))
            (:copier nil))

  ;; the name of this stream
  (name nil)
  ;; the file this stream is for
  (file nil)
  ;; the backup file namestring for the old file, for :IF-EXISTS
  ;; :RENAME or :RENAME-AND-DELETE.
  (original nil :type (or simple-string null))
  (delete-original nil)       ; for :if-exists :rename-and-delete
  ;;; the number of bytes per element
  (element-size 1 :type index)
  ;; the type of element being transfered
  (element-type 'base-char)
  ;; the Unix file descriptor
  (fd -1 :type #!-win32 fixnum #!+win32 sb!vm:signed-word)
  What do we know about the FD ?
  (fd-type :unknown :type keyword)
  ;; controls when the output buffer is flushed
  (buffering :full :type (member :full :line :none))
  ;; controls whether the input buffer must be cleared before output
  ;; (must be done for files, not for sockets, pipes and other data
  ;; sources where input and output aren't related).  non-NIL means
  ;; don't clear input buffer.
  (dual-channel-p nil)
  ;; character position if known -- this may run into bignums, but
  ;; we probably should flip it into null then for efficiency's sake...
  (char-pos nil :type (or unsigned-byte null))
  T if input is waiting on FD . : EOF if we hit EOF .
  (listen nil :type (member nil t :eof))
  ;; T if serve-event is allowed when this stream blocks
  (serve-events nil :type boolean)

  ;; the input buffer
  (instead (make-array 0 :element-type 'character :adjustable t :fill-pointer t) :type (array character (*)))
  (ibuf nil :type (or buffer null))
  (eof-forced-p nil :type (member t nil))

  ;; the output buffer
  (obuf nil :type (or buffer null))

  ;; output flushed, but not written due to non-blocking io?
  (output-queue nil)
  (handler nil)
  timeout specified for this stream as seconds or NIL if none
  (timeout nil :type (or single-float null))
  ;; pathname of the file this stream is opened to (returned by PATHNAME)
  (pathname nil :type (or pathname null))
  Not :  , because we want to match CHAR - SIZE !
  (external-format :latin-1)
  ;; fixed width, or function to call with a character
  (char-size 1 :type (or fixnum function))
  (output-bytes #'ill-out :type function)
  ;; a boolean indicating whether the stream is bivalent.  For
  ;; internal use only.
  (bivalent-p nil :type boolean))
(def!method print-object ((fd-stream fd-stream) stream)
  (declare (type stream stream))
  (print-unreadable-object (fd-stream stream :type t :identity t)
    (format stream "for ~S" (fd-stream-name fd-stream))))

  CORE OUTPUT FUNCTIONS

  Buffer the section of THING delimited by START and END by copying
;;; to output buffer(s) of stream.
(defun buffer-output (stream thing start end)
  (declare (index start end))
  (when (< end start)
    (error ":END before :START!"))
  (when (> end start)
    ;; Copy bytes from THING to buffers.
    (flet ((copy-to-buffer (buffer tail count)
             (declare (buffer buffer) (index tail count))
             (aver (plusp count))
             (let ((sap (buffer-sap buffer)))
               (etypecase thing
                 (system-area-pointer
                  (system-area-ub8-copy thing start sap tail count))
                 ((simple-unboxed-array (*))
                  (copy-ub8-to-system-area thing start sap tail count))))
  Not INCF ! If another thread has moved tail from under
             ;; us, we don't want to accidentally increment tail
             ;; beyond buffer-length.
             (setf (buffer-tail buffer) (+ count tail))
             (incf start count)))
      (tagbody
  First copy is special : the buffer may already contain
         ;; something, or be even full.
         (let* ((obuf (fd-stream-obuf stream))
                (tail (buffer-tail obuf))
                (space (- (buffer-length obuf) tail)))
           (when (plusp space)
             (copy-to-buffer obuf tail (min space (- end start)))
             (go :more-output-p)))
       :flush-and-fill
         ;; Later copies should always have an empty buffer, since
         ;; they are freshly flushed, but if another thread is
         ;; stomping on the same buffer that might not be the case.
         (let* ((obuf (flush-output-buffer stream))
                (tail (buffer-tail obuf))
                (space (- (buffer-length obuf) tail)))
           (copy-to-buffer obuf tail (min space (- end start))))
       :more-output-p
         (when (> end start)
           (go :flush-and-fill))))))

;;; Flush the current output buffer of the stream, ensuring that the
;;; new buffer is empty. Returns (for convenience) the new output
  buffer -- which may or may not be EQ to the old one . If the is no
;;; queued output we try to write the buffer immediately -- otherwise
;;; we queue it for later.
(defun flush-output-buffer (stream)
  (let ((obuf (fd-stream-obuf stream)))
    (when obuf
      (let ((head (buffer-head obuf))
            (tail (buffer-tail obuf)))
        (cond ((eql head tail)
               ;; Buffer is already empty -- just ensure that is is
  set to zero as well .
               (reset-buffer obuf))
              ((fd-stream-output-queue stream)
               ;; There is already stuff on the queue -- go directly
               ;; there.
               (aver (< head tail))
               (%queue-and-replace-output-buffer stream))
              (t
               ;; Try a non-blocking write, if SERVE-EVENT is allowed, queue
               ;; whatever is left over. Otherwise wait until we can write.
               (aver (< head tail))
               (synchronize-stream-output stream)
               (loop
                 (let ((length (- tail head)))
                   (multiple-value-bind (count errno)
                       (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap obuf)
                                           head length)
                     (flet ((queue-or-wait ()
                              (if (fd-stream-serve-events stream)
                                  (return (%queue-and-replace-output-buffer stream))
                                  (or (wait-until-fd-usable (fd-stream-fd stream) :output
                                                            (fd-stream-timeout stream)
                                                            nil)
                                      (signal-timeout 'io-timeout
                                                      :stream stream
                                                      :direction :output
                                                      :seconds (fd-stream-timeout stream))))))
                        (cond ((eql count length)
                               ;; Complete write -- we can use the same buffer.
                               (return (reset-buffer obuf)))
                              (count
                               ;; Partial write -- update buffer status and
                               ;; queue or wait.
                               (incf head count)
                               (setf (buffer-head obuf) head)
                               (queue-or-wait))
                              #!-win32
                              ((eql errno sb!unix:ewouldblock)
  Blocking , queue or wair .
                               (queue-or-wait))
                              ;; if interrupted on win32, just try again
                              #!+win32 ((eql errno sb!unix:eintr))
                              (t
                               (simple-stream-perror "Couldn't write to ~s"
                                                     stream errno)))))))))))))

;;; Helper for FLUSH-OUTPUT-BUFFER -- returns the new buffer.
(defun %queue-and-replace-output-buffer (stream)
  (aver (fd-stream-serve-events stream))
  (let ((queue (fd-stream-output-queue stream))
        (later (list (or (fd-stream-obuf stream) (bug "Missing obuf."))))
        (new (get-buffer)))
    ;; Important: before putting the buffer on queue, give the stream
    ;; a new one. If we get an interrupt and unwind losing the buffer
  is relatively OK , but having the same buffer in two places
    ;; would be bad.
    (setf (fd-stream-obuf stream) new)
    (cond (queue
           (nconc queue later))
          (t
           (setf (fd-stream-output-queue stream) later)))
    (unless (fd-stream-handler stream)
      (setf (fd-stream-handler stream)
            (add-fd-handler (fd-stream-fd stream)
                            :output
                            (lambda (fd)
                              (declare (ignore fd))
                              (write-output-from-queue stream)))))
    new))

;;; This is called by the FD-HANDLER for the stream when output is
;;; possible.
(defun write-output-from-queue (stream)
  (aver (fd-stream-serve-events stream))
  (synchronize-stream-output stream)
  (let (not-first-p)
    (tagbody
     :pop-buffer
       (let* ((buffer (pop (fd-stream-output-queue stream)))
              (head (buffer-head buffer))
              (length (- (buffer-tail buffer) head)))
         (declare (index head length))
         (aver (>= length 0))
         (multiple-value-bind (count errno)
             (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap buffer)
                                 head length)
           (cond ((eql count length)
                  ;; Complete write, see if we can do another right
                  ;; away, or remove the handler if we're done.
                  (release-buffer buffer)
                  (cond ((fd-stream-output-queue stream)
                         (setf not-first-p t)
                         (go :pop-buffer))
                        (t
                         (let ((handler (fd-stream-handler stream)))
                           (aver handler)
                           (setf (fd-stream-handler stream) nil)
                           (remove-fd-handler handler)))))
                 (count
                  ;; Partial write. Update buffer status and requeue.
                  (aver (< count length))
  Do not use INCF ! Another thread might have moved head .
                  (setf (buffer-head buffer) (+ head count))
                  (push buffer (fd-stream-output-queue stream)))
                 (not-first-p
                  ;; We tried to do multiple writes, and finally our
  luck ran out .  .
                  (push buffer (fd-stream-output-queue stream)))
                 (t
  Could not write on the first try at all !
                  #!+win32
                  (simple-stream-perror "Couldn't write to ~S." stream errno)
                  #!-win32
                  (if (= errno sb!unix:ewouldblock)
                      (bug "Unexpected blocking in WRITE-OUTPUT-FROM-QUEUE.")
                      (simple-stream-perror "Couldn't write to ~S"
                                            stream errno))))))))
  nil)

;;; Try to write THING directly to STREAM without buffering, if
;;; possible. If direct write doesn't happen, buffer.
(defun write-or-buffer-output (stream thing start end)
  (declare (index start end))
  (cond ((fd-stream-output-queue stream)
         (buffer-output stream thing start end))
        ((< end start)
         (error ":END before :START!"))
        ((> end start)
         (let ((length (- end start)))
           (synchronize-stream-output stream)
           (multiple-value-bind (count errno)
               (sb!unix:unix-write (fd-stream-fd stream) thing start length)
             (cond ((eql count length)
                    ;; Complete write -- done!
                    )
                   (count
                    (aver (< count length))
                    ;; Partial write -- buffer the rest.
                    (buffer-output stream thing (+ start count) end))
                   (t
                    ;; Could not write -- buffer or error.
                    #!+win32
                    (simple-stream-perror "couldn't write to ~s" stream errno)
                    #!-win32
                    (if (= errno sb!unix:ewouldblock)
                        (buffer-output stream thing start end)
                        (simple-stream-perror "couldn't write to ~s" stream errno)))))))))

  Deprecated -- can go away after 1.1 or so . Deprecated because
  this is not something we want to export . Nikodemus thinks the
;;; right thing is to support a low-level non-stream like IO layer,
;;; akin to java.nio.
(declaim (inline output-raw-bytes))
(define-deprecated-function :late "1.0.8.16" output-raw-bytes write-sequence
    (stream thing &optional start end)
  (write-or-buffer-output stream thing (or start 0) (or end (length thing))))

;;;; output routines and related noise

(defvar *output-routines* ()
  #!+sb-doc
  "List of all available output routines. Each element is a list of the
  element-type output, the kind of buffering, the function name, and the number
  of bytes per element.")

;;; common idioms for reporting low-level stream and file problems
(defun simple-stream-perror (note-format stream errno)
  (error 'simple-stream-error
         :stream stream
         :format-control "~@<~?: ~2I~_~A~:>"
         :format-arguments (list note-format (list stream) (strerror errno))))
(defun simple-file-perror (note-format pathname errno)
  (error 'simple-file-error
         :pathname pathname
         :format-control "~@<~?: ~2I~_~A~:>"
         :format-arguments
         (list note-format (list pathname) (strerror errno))))

(defun c-string-encoding-error (external-format code)
  (error 'c-string-encoding-error
         :external-format external-format
         :code code))
(defun c-string-decoding-error (external-format sap offset count)
  (error 'c-string-decoding-error
         :external-format external-format
         :octets (sap-ref-octets sap offset count)))

;;; Returning true goes into end of file handling, false will enter another
;;; round of input buffer filling followed by re-entering character decode.
(defun stream-decoding-error-and-handle (stream octet-count)
  (restart-case
      (error 'stream-decoding-error
             :external-format (stream-external-format stream)
             :stream stream
             :octets (let ((buffer (fd-stream-ibuf stream)))
                       (sap-ref-octets (buffer-sap buffer)
                                       (buffer-head buffer)
                                       octet-count)))
    (attempt-resync ()
      :report (lambda (stream)
                (format stream
                        "~@<Attempt to resync the stream at a ~
                        character boundary and continue.~@:>"))
      (fd-stream-resync stream)
      nil)
    (force-end-of-file ()
      :report (lambda (stream)
                (format stream "~@<Force an end of file.~@:>"))
      (setf (fd-stream-eof-forced-p stream) t))
    (input-replacement (string)
      :report (lambda (stream)
                (format stream "~@<Use string as replacement input, ~
                               attempt to resync at a character ~
                               boundary and continue.~@:>"))
      :interactive (lambda ()
                     (format *query-io* "~@<Enter a string: ~@:>")
                     (finish-output *query-io*)
                     (list (read *query-io*)))
      (let ((string (reverse (string string)))
            (instead (fd-stream-instead stream)))
        (dotimes (i (length string))
          (vector-push-extend (char string i) instead))
        (fd-stream-resync stream)
        (when (> (length string) 0)
          (setf (fd-stream-listen stream) t)))
      nil)))

(defun stream-encoding-error-and-handle (stream code)
  (restart-case
      (error 'stream-encoding-error
             :external-format (stream-external-format stream)
             :stream stream
             :code code)
    (output-nothing ()
      :report (lambda (stream)
                (format stream "~@<Skip output of this character.~@:>"))
      (throw 'output-nothing nil))
    (output-replacement (string)
      :report (lambda (stream)
                (format stream "~@<Output replacement string.~@:>"))
      :interactive (lambda ()
                     (format *query-io* "~@<Enter a string: ~@:>")
                     (finish-output *query-io*)
                     (list (read *query-io*)))
      (let ((string (string string)))
        (fd-sout stream (string string) 0 (length string)))
      (throw 'output-nothing nil))))

(defun external-format-encoding-error (stream code)
  (if (streamp stream)
      (stream-encoding-error-and-handle stream code)
      (c-string-encoding-error stream code)))

(defun synchronize-stream-output (stream)
  ;; If we're reading and writing on the same file, flush buffered
  ;; input and rewind file position accordingly.
  (unless (fd-stream-dual-channel-p stream)
    (let ((adjust (nth-value 1 (flush-input-buffer stream))))
      (unless (eql 0 adjust)
        (sb!unix:unix-lseek (fd-stream-fd stream) (- adjust) sb!unix:l_incr)))))

(defun fd-stream-output-finished-p (stream)
  (let ((obuf (fd-stream-obuf stream)))
    (or (not obuf)
        (and (zerop (buffer-tail obuf))
             (not (fd-stream-output-queue stream))))))

(defmacro output-wrapper/variable-width ((stream size buffering restart)
                                         &body body)
  (let ((stream-var (gensym "STREAM")))
    `(let* ((,stream-var ,stream)
            (obuf (fd-stream-obuf ,stream-var))
            (tail (buffer-tail obuf))
            (size ,size))
      ,(unless (eq (car buffering) :none)
         `(when (<= (buffer-length obuf) (+ tail size))
            (setf obuf (flush-output-buffer ,stream-var)
                  tail (buffer-tail obuf))))
      ,(unless (eq (car buffering) :none)
         ;; FIXME: Why this here? Doesn't seem necessary.
         `(synchronize-stream-output ,stream-var))
      ,(if restart
           `(catch 'output-nothing
              ,@body
              (setf (buffer-tail obuf) (+ tail size)))
           `(progn
             ,@body
             (setf (buffer-tail obuf) (+ tail size))))
      ,(ecase (car buffering)
         (:none
          `(flush-output-buffer ,stream-var))
         (:line
          `(when (eql byte #\Newline)
             (flush-output-buffer ,stream-var)))
         (:full))
    (values))))

(defmacro output-wrapper ((stream size buffering restart) &body body)
  (let ((stream-var (gensym "STREAM")))
    `(let* ((,stream-var ,stream)
            (obuf (fd-stream-obuf ,stream-var))
            (tail (buffer-tail obuf)))
      ,(unless (eq (car buffering) :none)
         `(when (<= (buffer-length obuf) (+ tail ,size))
            (setf obuf (flush-output-buffer ,stream-var)
                  tail (buffer-tail obuf))))
      ;; FIXME: Why this here? Doesn't seem necessary.
      ,(unless (eq (car buffering) :none)
         `(synchronize-stream-output ,stream-var))
      ,(if restart
           `(catch 'output-nothing
              ,@body
              (setf (buffer-tail obuf) (+ tail ,size)))
           `(progn
             ,@body
             (setf (buffer-tail obuf) (+ tail ,size))))
      ,(ecase (car buffering)
         (:none
          `(flush-output-buffer ,stream-var))
         (:line
          `(when (eql byte #\Newline)
             (flush-output-buffer ,stream-var)))
         (:full))
    (values))))

(defmacro def-output-routines/variable-width
    ((name-fmt size restart external-format &rest bufferings)
     &body body)
  (declare (optimize (speed 1)))
  (cons 'progn
        (mapcar
            (lambda (buffering)
              (let ((function
                     (intern (format nil name-fmt (string (car buffering))))))
                `(progn
                   (defun ,function (stream byte)
                     (declare (ignorable byte))
                     (output-wrapper/variable-width (stream ,size ,buffering ,restart)
                       ,@body))
                   (setf *output-routines*
                         (nconc *output-routines*
                                ',(mapcar
                                   (lambda (type)
                                     (list type
                                           (car buffering)
                                           function
                                           1
                                           external-format))
                                   (cdr buffering)))))))
            bufferings)))

;;; Define output routines that output numbers SIZE bytes long for the
;;; given bufferings. Use BODY to do the actual output.
(defmacro def-output-routines ((name-fmt size restart &rest bufferings)
                               &body body)
  (declare (optimize (speed 1)))
  (cons 'progn
        (mapcar
            (lambda (buffering)
              (let ((function
                     (intern (format nil name-fmt (string (car buffering))))))
                `(progn
                   (defun ,function (stream byte)
                     (output-wrapper (stream ,size ,buffering ,restart)
                       ,@body))
                   (setf *output-routines*
                         (nconc *output-routines*
                                ',(mapcar
                                   (lambda (type)
                                     (list type
                                           (car buffering)
                                           function
                                           size
                                           nil))
                                   (cdr buffering)))))))
            bufferings)))

;;; FIXME: is this used anywhere any more?
(def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
                      1
                      t
                      (:none character)
                      (:line character)
                      (:full character))
  (if (eql byte #\Newline)
      (setf (fd-stream-char-pos stream) 0)
      (incf (fd-stream-char-pos stream)))
  (setf (sap-ref-8 (buffer-sap obuf) tail)
        (char-code byte)))

(def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"
                      1
                      nil
                      (:none (unsigned-byte 8))
                      (:full (unsigned-byte 8)))
  (setf (sap-ref-8 (buffer-sap obuf) tail)
        byte))

(def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED"
                      1
                      nil
                      (:none (signed-byte 8))
                      (:full (signed-byte 8)))
  (setf (signed-sap-ref-8 (buffer-sap obuf) tail)
        byte))

(def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED"
                      2
                      nil
                      (:none (unsigned-byte 16))
                      (:full (unsigned-byte 16)))
  (setf (sap-ref-16 (buffer-sap obuf) tail)
        byte))

(def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED"
                      2
                      nil
                      (:none (signed-byte 16))
                      (:full (signed-byte 16)))
  (setf (signed-sap-ref-16 (buffer-sap obuf) tail)
        byte))

(def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED"
                      4
                      nil
                      (:none (unsigned-byte 32))
                      (:full (unsigned-byte 32)))
  (setf (sap-ref-32 (buffer-sap obuf) tail)
        byte))

(def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED"
                      4
                      nil
                      (:none (signed-byte 32))
                      (:full (signed-byte 32)))
  (setf (signed-sap-ref-32 (buffer-sap obuf) tail)
        byte))

#+#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or))
(progn
  (def-output-routines ("OUTPUT-UNSIGNED-LONG-LONG-~A-BUFFERED"
                        8
                        nil
                        (:none (unsigned-byte 64))
                        (:full (unsigned-byte 64)))
    (setf (sap-ref-64 (buffer-sap obuf) tail)
          byte))
  (def-output-routines ("OUTPUT-SIGNED-LONG-LONG-~A-BUFFERED"
                        8
                        nil
                        (:none (signed-byte 64))
                        (:full (signed-byte 64)))
    (setf (signed-sap-ref-64 (buffer-sap obuf) tail)
          byte)))

;;; the routine to use to output a string. If the stream is
;;; unbuffered, slam the string down the file descriptor, otherwise
;;; use OUTPUT-RAW-BYTES to buffer the string. Update charpos by
;;; checking to see where the last newline was.
(defun fd-sout (stream thing start end)
  (declare (type fd-stream stream) (type string thing))
  (let ((start (or start 0))
        (end (or end (length (the vector thing)))))
    (declare (fixnum start end))
    (let ((last-newline
           (string-dispatch (simple-base-string
                             #!+sb-unicode
                             (simple-array character (*))
                             string)
               thing
             (position #\newline thing :from-end t
                       :start start :end end))))
      (if (and (typep thing 'base-string)
               (eq (fd-stream-external-format-keyword stream) :latin-1))
          (ecase (fd-stream-buffering stream)
            (:full
             (buffer-output stream thing start end))
            (:line
             (buffer-output stream thing start end)
             (when last-newline
               (flush-output-buffer stream)))
            (:none
             (write-or-buffer-output stream thing start end)))
          (ecase (fd-stream-buffering stream)
            (:full (funcall (fd-stream-output-bytes stream)
                            stream thing nil start end))
            (:line (funcall (fd-stream-output-bytes stream)
                            stream thing last-newline start end))
            (:none (funcall (fd-stream-output-bytes stream)
                            stream thing t start end))))
      (if last-newline
          (setf (fd-stream-char-pos stream) (- end last-newline 1))
          (incf (fd-stream-char-pos stream) (- end start))))))

(defstruct (external-format
             (:constructor %make-external-format)
             (:conc-name ef-)
             (:predicate external-format-p)
             (:copier %copy-external-format))
  All the names that can refer to this external format .   The first
  ;; one is the canonical name.
  (names (missing-arg) :type list :read-only t)
  (default-replacement-character (missing-arg) :type character)
  (read-n-chars-fun (missing-arg) :type function)
  (read-char-fun (missing-arg) :type function)
  (write-n-bytes-fun (missing-arg) :type function)
  (write-char-none-buffered-fun (missing-arg) :type function)
  (write-char-line-buffered-fun (missing-arg) :type function)
  (write-char-full-buffered-fun (missing-arg) :type function)
  ;; Can be nil for fixed-width formats.
  (resync-fun nil :type (or function null))
  (bytes-for-char-fun (missing-arg) :type function)
  (read-c-string-fun (missing-arg) :type function)
  (write-c-string-fun (missing-arg) :type function)
  ;; We indirect through symbols in these functions so that a
  ;; developer working on the octets code can easily redefine things
  ;; and use the new function definition without redefining the
  ;; external format as well.  The slots above don't do any
  ;; indirection because a developer working with those slots would be
  ;; redefining the external format anyway.
  (octets-to-string-fun (missing-arg) :type function)
  (string-to-octets-fun (missing-arg) :type function))

(defun ef-char-size (ef-entry)
  (if (variable-width-external-format-p ef-entry)
      (bytes-for-char-fun ef-entry)
      (funcall (bytes-for-char-fun ef-entry) #\x)))

(defun wrap-external-format-functions (external-format fun)
  (let ((result (%copy-external-format external-format)))
    (macrolet ((frob (accessor)
                 `(setf (,accessor result) (funcall fun (,accessor result)))))
      (frob ef-read-n-chars-fun)
      (frob ef-read-char-fun)
      (frob ef-write-n-bytes-fun)
      (frob ef-write-char-none-buffered-fun)
      (frob ef-write-char-line-buffered-fun)
      (frob ef-write-char-full-buffered-fun)
      (frob ef-resync-fun)
      (frob ef-bytes-for-char-fun)
      (frob ef-read-c-string-fun)
      (frob ef-write-c-string-fun)
      (frob ef-octets-to-string-fun)
      (frob ef-string-to-octets-fun))
    result))

(defvar *external-formats* (make-hash-table)
  #!+sb-doc
  "Hashtable of all available external formats. The table maps from
  external-format names to EXTERNAL-FORMAT structures.")

(defun get-external-format (external-format)
  (flet ((keyword-external-format (keyword)
           (declare (type keyword keyword))
           (gethash keyword *external-formats*))
         (replacement-handlerify (entry replacement)
           (when entry
             (wrap-external-format-functions
              entry
              (lambda (fun)
                (and fun
                     (lambda (&rest rest)
                       (declare (dynamic-extent rest))
                       (handler-bind
                           ((stream-decoding-error
                             (lambda (c)
                               (declare (ignore c))
                               (invoke-restart 'input-replacement replacement)))
                            (stream-encoding-error
                             (lambda (c)
                               (declare (ignore c))
                               (invoke-restart 'output-replacement replacement)))
                            (octets-encoding-error
                             (lambda (c) (use-value replacement c)))
                            (octet-decoding-error
                             (lambda (c) (use-value replacement c))))
                         (apply fun rest)))))))))
    (typecase external-format
      (keyword (keyword-external-format external-format))
      ((cons keyword)
       (let ((entry (keyword-external-format (car external-format)))
             (replacement (getf (cdr external-format) :replacement)))
         (if replacement
             (replacement-handlerify entry replacement)
             entry))))))

(defun get-external-format-or-lose (external-format)
  (or (get-external-format external-format)
      (error "Undefined external-format: ~S" external-format)))

(defun external-format-keyword (external-format)
  (typecase external-format
    (keyword external-format)
    ((cons keyword) (car external-format))))

(defun fd-stream-external-format-keyword (stream)
  (external-format-keyword (fd-stream-external-format stream)))

(defun canonize-external-format (external-format entry)
  (typecase external-format
    (keyword (first (ef-names entry)))
    ((cons keyword) (cons (first (ef-names entry)) (rest external-format)))))

;;; Find an output routine to use given the type and buffering. Return
;;; as multiple values the routine, the real type transfered, and the
;;; number of bytes per element.
(defun pick-output-routine (type buffering &optional external-format)
  (when (subtypep type 'character)
    (let ((entry (get-external-format-or-lose external-format)))
      (return-from pick-output-routine
        (values (ecase buffering
                  (:none (ef-write-char-none-buffered-fun entry))
                  (:line (ef-write-char-line-buffered-fun entry))
                  (:full (ef-write-char-full-buffered-fun entry)))
                'character
                1
                (ef-write-n-bytes-fun entry)
                (ef-char-size entry)
                (canonize-external-format external-format entry)))))
  (dolist (entry *output-routines*)
    (when (and (subtypep type (first entry))
               (eq buffering (second entry))
               (or (not (fifth entry))
                   (eq external-format (fifth entry))))
      (return-from pick-output-routine
        (values (symbol-function (third entry))
                (first entry)
                (fourth entry)))))
   : dealing with the buffering here leads to excessive code
  ;; explosion.
  ;;
   : also see comments in PICK - INPUT - ROUTINE
  ARB (  )
        if (subtypep type `(unsigned-byte ,i))
        do (return-from pick-output-routine
             (values
              (ecase buffering
                (:none
                 (lambda (stream byte)
                   (output-wrapper (stream (/ i 8) (:none) nil)
                     (loop for j from 0 below (/ i 8)
                           do (setf (sap-ref-8 (buffer-sap obuf)
                                               (+ j tail))
                                    (ldb (byte 8 (- i 8 (* j 8))) byte))))))
                (:full
                 (lambda (stream byte)
                   (output-wrapper (stream (/ i 8) (:full) nil)
                     (loop for j from 0 below (/ i 8)
                           do (setf (sap-ref-8 (buffer-sap obuf)
                                               (+ j tail))
                                    (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
              `(unsigned-byte ,i)
              (/ i 8))))
  ARB (  )
        if (subtypep type `(signed-byte ,i))
        do (return-from pick-output-routine
             (values
              (ecase buffering
                (:none
                 (lambda (stream byte)
                   (output-wrapper (stream (/ i 8) (:none) nil)
                     (loop for j from 0 below (/ i 8)
                           do (setf (sap-ref-8 (buffer-sap obuf)
                                               (+ j tail))
                                    (ldb (byte 8 (- i 8 (* j 8))) byte))))))
                (:full
                 (lambda (stream byte)
                   (output-wrapper (stream (/ i 8) (:full) nil)
                     (loop for j from 0 below (/ i 8)
                           do (setf (sap-ref-8 (buffer-sap obuf)
                                               (+ j tail))
                                    (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
              `(signed-byte ,i)
              (/ i 8)))))

;;;; input routines and related noise

;;; a list of all available input routines. Each element is a list of
;;; the element-type input, the function name, and the number of bytes
;;; per element.
(defvar *input-routines* ())

  Return whether a primitive partial read operation on STREAM 's FD
  would ( probably ) block .   Signal a ` simple - stream - error ' if the
;;; system call implementing this operation fails.
;;;
;;; It is "may" instead of "would" because "would" is not quite
;;; correct on win32.  However, none of the places that use it require
;;; further assurance than "may" versus "will definitely not".
(defun sysread-may-block-p (stream)
  #!+win32
  ;; This answers T at EOF on win32, I think.
  (not (sb!win32:fd-listen (fd-stream-fd stream)))
  #!-win32
  (not (sb!unix:unix-simple-poll (fd-stream-fd stream) :input 0)))

;;; If the read would block wait (using SERVE-EVENT) till input is available,
;;; then fill the input buffer, and return the number of bytes read. Throws
  to EOF - INPUT - CATCHER if the eof was reached .
(defun refill-input-buffer (stream)
  (dx-let ((fd (fd-stream-fd stream))
           (errno 0)
           (count 0))
    (tagbody
       #!+win32
       (go :main)

       ;; Check for blocking input before touching the stream if we are to
  serve events : if the FD is blocking , we do n't want to try an uninterruptible
       ;; read(). Regular files should never block, so we can elide the check.
       (if (and (neq :regular (fd-stream-fd-type stream))
                (sysread-may-block-p stream))
           (go :wait-for-input)
           (go :main))
       ;; These (:CLOSED-FLAME and :READ-ERROR) tags are here so what
       ;; we can signal errors outside the WITHOUT-INTERRUPTS.
     :closed-flame
       (closed-flame stream)
     :read-error
       (simple-stream-perror "couldn't read from ~S" stream errno)
     :wait-for-input
       ;; This tag is here so we can unwind outside the WITHOUT-INTERRUPTS
       ;; to wait for input if read tells us EWOULDBLOCK.
       (unless (wait-until-fd-usable fd :input (fd-stream-timeout stream)
                                     (fd-stream-serve-events stream))
         (signal-timeout 'io-timeout
                         :stream stream
                         :direction :input
                         :seconds (fd-stream-timeout stream)))
     :main
       ;; Since the read should not block, we'll disable the
       ;; interrupts here, so that we don't accidentally unwind and
       ;; leave the stream in an inconsistent state.

       ;; Execute the nlx outside without-interrupts to ensure the
       ;; resulting thunk is stack-allocatable.
       ((lambda (return-reason)
          (ecase return-reason
            ((nil))                     ; fast path normal cases
            ((:wait-for-input) (go #!-win32 :wait-for-input #!+win32 :main))
            ((:closed-flame)   (go :closed-flame))
            ((:read-error)     (go :read-error))))
        (without-interrupts
          ;; Check the buffer: if it is null, then someone has closed
          ;; the stream from underneath us. This is not ment to fix
          ;; multithreaded races, but to deal with interrupt handlers
          ;; closing the stream.
          (block nil
            (prog1 nil
              (let* ((ibuf (or (fd-stream-ibuf stream) (return :closed-flame)))
                     (sap (buffer-sap ibuf))
                     (length (buffer-length ibuf))
                     (head (buffer-head ibuf))
                     (tail (buffer-tail ibuf)))
                (declare (index length head tail)
                         (inline sb!unix:unix-read))
                (unless (zerop head)
                  (cond ((eql head tail)
                         ;; Buffer is empty, but not at yet reset -- make it so.
                         (setf head 0
                               tail 0)
                         (reset-buffer ibuf))
                        (t
                         ;; Buffer has things in it, but they are not at the
                         ;; head -- move them there.
                         (let ((n (- tail head)))
                           (system-area-ub8-copy sap head sap 0 n)
                           (setf head 0
                                 (buffer-head ibuf) head
                                 tail n
                                 (buffer-tail ibuf) tail)))))
                (setf (fd-stream-listen stream) nil)
                (setf (values count errno)
                      (sb!unix:unix-read fd (sap+ sap tail) (- length tail)))
                (cond ((null count)
                       (if (eql errno
                                #!+win32 sb!unix:eintr
                                #!-win32 sb!unix:ewouldblock)
                           (return :wait-for-input)
                           (return :read-error)))
                      ((zerop count)
                       (setf (fd-stream-listen stream) :eof)
                       (/show0 "THROWing EOF-INPUT-CATCHER")
                       (throw 'eof-input-catcher nil))
                      (t
  Success ! ( Do not use INCF , for sake of other threads . )
                       (setf (buffer-tail ibuf) (+ count tail))))))))))
    count))

;;; Make sure there are at least BYTES number of bytes in the input
;;; buffer. Keep calling REFILL-INPUT-BUFFER until that condition is met.
(defmacro input-at-least (stream bytes)
  (let ((stream-var (gensym "STREAM"))
        (bytes-var (gensym "BYTES"))
        (buffer-var (gensym "IBUF")))
    `(let* ((,stream-var ,stream)
            (,bytes-var ,bytes)
            (,buffer-var (fd-stream-ibuf ,stream-var)))
       (loop
         (when (>= (- (buffer-tail ,buffer-var)
                      (buffer-head ,buffer-var))
                   ,bytes-var)
           (return))
         (refill-input-buffer ,stream-var)))))

(defmacro input-wrapper/variable-width ((stream bytes eof-error eof-value)
                                        &body read-forms)
  (let ((stream-var (gensym "STREAM"))
        (retry-var (gensym "RETRY"))
        (element-var (gensym "ELT")))
    `(let* ((,stream-var ,stream)
            (ibuf (fd-stream-ibuf ,stream-var))
            (size nil))
       (block use-instead
         (when (fd-stream-eof-forced-p ,stream-var)
           (setf (fd-stream-eof-forced-p ,stream-var) nil)
           (return-from use-instead
             (eof-or-lose ,stream-var ,eof-error ,eof-value)))
         (let ((,element-var nil)
               (decode-break-reason nil))
           (do ((,retry-var t))
               ((not ,retry-var))
             (if (> (length (fd-stream-instead ,stream-var)) 0)
                 (let* ((instead (fd-stream-instead ,stream-var))
                        (result (vector-pop instead))
                        (pointer (fill-pointer instead)))
                   (when (= pointer 0)
                     (setf (fd-stream-listen ,stream-var) nil))
                   (return-from use-instead result))
                 (unless
                     (catch 'eof-input-catcher
                       (setf decode-break-reason
                             (block decode-break-reason
                               (input-at-least ,stream-var ,(if (consp bytes)
                                                                (car bytes)
                                                                `(setq size ,bytes)))
                               (let* ((byte (sap-ref-8 (buffer-sap ibuf) (buffer-head ibuf))))
                                 (declare (ignorable byte))
                                 ,@(when (consp bytes)
                                     `((let ((sap (buffer-sap ibuf))
                                             (head (buffer-head ibuf)))
                                         (declare (ignorable sap head))
                                         (setq size ,(cadr bytes))
                                         (input-at-least ,stream-var size))))
                                 (setq ,element-var (locally ,@read-forms))
                                 (setq ,retry-var nil))
                               nil))
                       (when decode-break-reason
                         (when (stream-decoding-error-and-handle
                                stream decode-break-reason)
                           (setq ,retry-var nil)
                           (throw 'eof-input-catcher nil)))
                       t)
                   (let ((octet-count (- (buffer-tail ibuf)
                                         (buffer-head ibuf))))
                     (when (or (zerop octet-count)
                               (and (not ,element-var)
                                    (not decode-break-reason)
                                    (stream-decoding-error-and-handle
                                     stream octet-count)))
                       (setq ,retry-var nil))))))
           (cond (,element-var
                  (incf (buffer-head ibuf) size)
                  ,element-var)
                 (t
                  (eof-or-lose ,stream-var ,eof-error ,eof-value))))))))

;;; a macro to wrap around all input routines to handle EOF-ERROR noise
(defmacro input-wrapper ((stream bytes eof-error eof-value) &body read-forms)
  (let ((stream-var (gensym "STREAM"))
        (element-var (gensym "ELT")))
    `(let* ((,stream-var ,stream)
            (ibuf (fd-stream-ibuf ,stream-var)))
       (if (> (length (fd-stream-instead ,stream-var)) 0)
           (bug "INSTEAD not empty in INPUT-WRAPPER for ~S" ,stream-var)
           (let ((,element-var
                  (catch 'eof-input-catcher
                    (input-at-least ,stream-var ,bytes)
                    (locally ,@read-forms))))
             (cond (,element-var
                    (incf (buffer-head (fd-stream-ibuf ,stream-var)) ,bytes)
                    ,element-var)
                   (t
                    (eof-or-lose ,stream-var ,eof-error ,eof-value))))))))

(defmacro def-input-routine/variable-width (name
                                            (type external-format size sap head)
                                            &rest body)
  `(progn
     (defun ,name (stream eof-error eof-value)
       (input-wrapper/variable-width (stream ,size eof-error eof-value)
         (let ((,sap (buffer-sap ibuf))
               (,head (buffer-head ibuf)))
           ,@body)))
     (setf *input-routines*
           (nconc *input-routines*
                  (list (list ',type ',name 1 ',external-format))))))

(defmacro def-input-routine (name
                             (type size sap head)
                             &rest body)
  `(progn
     (defun ,name (stream eof-error eof-value)
       (input-wrapper (stream ,size eof-error eof-value)
         (let ((,sap (buffer-sap ibuf))
               (,head (buffer-head ibuf)))
           ,@body)))
     (setf *input-routines*
           (nconc *input-routines*
                  (list (list ',type ',name ',size nil))))))

;;; STREAM-IN routine for reading a string char
(def-input-routine input-character
                   (character 1 sap head)
  (code-char (sap-ref-8 sap head)))

  STREAM - IN routine for reading an unsigned 8 bit number
(def-input-routine input-unsigned-8bit-byte
                   ((unsigned-byte 8) 1 sap head)
  (sap-ref-8 sap head))

  STREAM - IN routine for reading a signed 8 bit number
(def-input-routine input-signed-8bit-number
                   ((signed-byte 8) 1 sap head)
  (signed-sap-ref-8 sap head))

  STREAM - IN routine for reading an unsigned 16 bit number
(def-input-routine input-unsigned-16bit-byte
                   ((unsigned-byte 16) 2 sap head)
  (sap-ref-16 sap head))

  STREAM - IN routine for reading a signed 16 bit number
(def-input-routine input-signed-16bit-byte
                   ((signed-byte 16) 2 sap head)
  (signed-sap-ref-16 sap head))

  STREAM - IN routine for reading a unsigned 32 bit number
(def-input-routine input-unsigned-32bit-byte
                   ((unsigned-byte 32) 4 sap head)
  (sap-ref-32 sap head))

  STREAM - IN routine for reading a signed 32 bit number
(def-input-routine input-signed-32bit-byte
                   ((signed-byte 32) 4 sap head)
  (signed-sap-ref-32 sap head))

#+#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or))
(progn
  (def-input-routine input-unsigned-64bit-byte
      ((unsigned-byte 64) 8 sap head)
    (sap-ref-64 sap head))
  (def-input-routine input-signed-64bit-byte
      ((signed-byte 64) 8 sap head)
    (signed-sap-ref-64 sap head)))

;;; Find an input routine to use given the type. Return as multiple
;;; values the routine, the real type transfered, and the number of
;;; bytes per element (and for character types string input routine).
(defun pick-input-routine (type &optional external-format)
  (when (subtypep type 'character)
    (let ((entry (get-external-format-or-lose external-format)))
      (return-from pick-input-routine
        (values (ef-read-char-fun entry)
                'character
                1
                (ef-read-n-chars-fun entry)
                (ef-char-size entry)
                (canonize-external-format external-format entry)))))
  (dolist (entry *input-routines*)
    (when (and (subtypep type (first entry))
               (or (not (fourth entry))
                   (eq external-format (fourth entry))))
      (return-from pick-input-routine
        (values (symbol-function (second entry))
                (first entry)
                (third entry)))))
  ;; FIXME: let's do it the hard way, then (but ignore things like
  ;; endianness, efficiency, and the necessary coupling between these
  and the output routines ) .   -- CSR , 2004 - 02 - 09
  ARB ( well ,  really )
        if (subtypep type `(unsigned-byte ,i))
        do (return-from pick-input-routine
             (values
              (lambda (stream eof-error eof-value)
                (input-wrapper (stream (/ i 8) eof-error eof-value)
                  (let ((sap (buffer-sap ibuf))
                        (head (buffer-head ibuf)))
                    (loop for j from 0 below (/ i 8)
                          with result = 0
                          do (setf result
                                   (+ (* 256 result)
                                      (sap-ref-8 sap (+ head j))))
                          finally (return result)))))
              `(unsigned-byte ,i)
              (/ i 8))))
  ARB ( well ,  really )
        if (subtypep type `(signed-byte ,i))
        do (return-from pick-input-routine
             (values
              (lambda (stream eof-error eof-value)
                (input-wrapper (stream (/ i 8) eof-error eof-value)
                  (let ((sap (buffer-sap ibuf))
                        (head (buffer-head ibuf)))
                    (loop for j from 0 below (/ i 8)
                          with result = 0
                          do (setf result
                                   (+ (* 256 result)
                                      (sap-ref-8 sap (+ head j))))
                          finally (return (if (logbitp (1- i) result)
                                              (dpb result (byte i 0) -1)
                                              result))))))
              `(signed-byte ,i)
              (/ i 8)))))

  the N - BIN method for FD - STREAMs
;;;
;;; Note that this blocks in UNIX-READ. It is generally used where
;;; there is a definite amount of reading to be done, so blocking
;;; isn't too problematical.
(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p
                               &aux (total-copied 0))
  (declare (type fd-stream stream))
  (declare (type index start requested total-copied))
  (aver (= (length (fd-stream-instead stream)) 0))
  (do ()
      (nil)
    (let* ((remaining-request (- requested total-copied))
           (ibuf (fd-stream-ibuf stream))
           (head (buffer-head ibuf))
           (tail (buffer-tail ibuf))
           (available (- tail head))
           (n-this-copy (min remaining-request available))
           (this-start (+ start total-copied))
           (this-end (+ this-start n-this-copy))
           (sap (buffer-sap ibuf)))
      (declare (type index remaining-request head tail available))
      (declare (type index n-this-copy))
      ;; Copy data from stream buffer into user's buffer.
      (%byte-blt sap head buffer this-start this-end)
      (incf (buffer-head ibuf) n-this-copy)
      (incf total-copied n-this-copy)
      ;; Maybe we need to refill the stream buffer.
      (cond (;; If there were enough data in the stream buffer, we're done.
             (eql total-copied requested)
             (return total-copied))
  If EOF , we 're done in another way .
             (null (catch 'eof-input-catcher (refill-input-buffer stream)))
             (if eof-error-p
                 (error 'end-of-file :stream stream)
                 (return total-copied)))
            ;; Otherwise we refilled the stream buffer, so fall
            ;; through into another pass of the loop.
            ))))

(defun fd-stream-resync (stream)
  (let ((entry (get-external-format (fd-stream-external-format stream))))
    (when entry
      (funcall (ef-resync-fun entry) stream))))

(defun get-fd-stream-character-sizer (stream)
  (let ((entry (get-external-format (fd-stream-external-format stream))))
    (when entry
      (ef-bytes-for-char-fun entry))))

(defun fd-stream-character-size (stream char)
  (let ((sizer (get-fd-stream-character-sizer stream)))
    (when sizer (funcall sizer char))))

(defun fd-stream-string-size (stream string)
  (let ((sizer (get-fd-stream-character-sizer stream)))
    (when sizer
      (loop for char across string summing (funcall sizer char)))))

(defun find-external-format (external-format)
  (when external-format
    (get-external-format external-format)))

(defun variable-width-external-format-p (ef-entry)
  (and ef-entry (not (null (ef-resync-fun ef-entry)))))

(defun bytes-for-char-fun (ef-entry)
  (if ef-entry (ef-bytes-for-char-fun ef-entry) (constantly 1)))

(defmacro define-unibyte-mapping-external-format
    (canonical-name (&rest other-names) &body exceptions)
  (let ((->code-name (symbolicate canonical-name '->code-mapper))
        (code->-name (symbolicate 'code-> canonical-name '-mapper))
        (get-bytes-name (symbolicate 'get- canonical-name '-bytes))
        (string->-name (symbolicate 'string-> canonical-name))
        (define-string*-name (symbolicate 'define- canonical-name '->string*))
        (string*-name (symbolicate canonical-name '->string*))
        (define-string-name (symbolicate 'define- canonical-name '->string))
        (string-name (symbolicate canonical-name '->string))
        (->string-aref-name (symbolicate canonical-name '->string-aref)))
    `(progn
       (define-unibyte-mapper ,->code-name ,code->-name
         ,@exceptions)
       (declaim (inline ,get-bytes-name))
       (defun ,get-bytes-name (string pos)
         (declare (optimize speed (safety 0))
                  (type simple-string string)
                  (type array-range pos))
         (get-latin-bytes #',code->-name ,canonical-name string pos))
       (defun ,string->-name (string sstart send null-padding)
         (declare (optimize speed (safety 0))
                  (type simple-string string)
                  (type array-range sstart send))
         (values (string->latin% string sstart send #',get-bytes-name null-padding)))
       (defmacro ,define-string*-name (accessor type)
         (declare (ignore type))
         (let ((name (make-od-name ',string*-name accessor)))
           `(progn
              (defun ,name (string sstart send array astart aend)
                (,(make-od-name 'latin->string* accessor)
                  string sstart send array astart aend #',',->code-name)))))
       (instantiate-octets-definition ,define-string*-name)
       (defmacro ,define-string-name (accessor type)
         (declare (ignore type))
         (let ((name (make-od-name ',string-name accessor)))
           `(progn
              (defun ,name (array astart aend)
                (,(make-od-name 'latin->string accessor)
                  array astart aend #',',->code-name)))))
       (instantiate-octets-definition ,define-string-name)
       (define-unibyte-external-format ,canonical-name ,other-names
         (let ((octet (,code->-name bits)))
           (if octet
               (setf (sap-ref-8 sap tail) octet)
               (external-format-encoding-error stream bits)))
         (let ((code (,->code-name byte)))
           (if code
               (code-char code)
               (return-from decode-break-reason 1)))
         ,->string-aref-name
         ,string->-name))))

(defmacro define-unibyte-external-format
    (canonical-name (&rest other-names)
     out-form in-form octets-to-string-symbol string-to-octets-symbol)
  `(define-external-format/variable-width (,canonical-name ,@other-names)
     t #\? 1
     ,out-form
     1
     ,in-form
     ,octets-to-string-symbol
     ,string-to-octets-symbol))

(defmacro define-external-format/variable-width
    (external-format output-restart replacement-character
     out-size-expr out-expr in-size-expr in-expr
     octets-to-string-sym string-to-octets-sym)
  (let* ((name (first external-format))
         (out-function (symbolicate "OUTPUT-BYTES/" name))
         (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" (string name)))
         (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name))
         (in-char-function (symbolicate "INPUT-CHAR/" name))
         (resync-function (symbolicate "RESYNC/" name))
         (size-function (symbolicate "BYTES-FOR-CHAR/" name))
         (read-c-string-function (symbolicate "READ-FROM-C-STRING/" name))
         (output-c-string-function (symbolicate "OUTPUT-TO-C-STRING/" name))
         (n-buffer (gensym "BUFFER")))
    `(progn
      (defun ,size-function (byte)
        (declare (ignorable byte))
        ,out-size-expr)
      (defun ,out-function (stream string flush-p start end)
        (let ((start (or start 0))
              (end (or end (length string))))
          (declare (type index start end))
          (synchronize-stream-output stream)
          (unless (<= 0 start end (length string))
            (sequence-bounding-indices-bad-error string start end))
          (do ()
              ((= end start))
            (let ((obuf (fd-stream-obuf stream)))
              (string-dispatch (simple-base-string
                                #!+sb-unicode (simple-array character (*))
                                string)
                  string
                (let ((len (buffer-length obuf))
                      (sap (buffer-sap obuf))
                      ;; FIXME: Rename
                      (tail (buffer-tail obuf)))
                  (declare (type index tail)
                           ;; STRING bounds have already been checked.
                           (optimize (safety 0)))
                  (,@(if output-restart
                         `(catch 'output-nothing)
                         `(progn))
                     (do* ()
                          ((or (= start end) (< (- len tail) 4)))
                       (let* ((byte (aref string start))
                              (bits (char-code byte))
                              (size ,out-size-expr))
                         ,out-expr
                         (incf tail size)
                         (setf (buffer-tail obuf) tail)
                         (incf start)))
                     (go flush))
  Exited via CATCH : skip the current character .
                  (incf start))))
           flush
            (when (< start end)
              (flush-output-buffer stream)))
          (when flush-p
            (flush-output-buffer stream))))
      (def-output-routines/variable-width (,format
                                           ,out-size-expr
                                           ,output-restart
                                           ,external-format
                                           (:none character)
                                           (:line character)
                                           (:full character))
          (if (eql byte #\Newline)
              (setf (fd-stream-char-pos stream) 0)
              (incf (fd-stream-char-pos stream)))
        (let ((bits (char-code byte))
              (sap (buffer-sap obuf))
              (tail (buffer-tail obuf)))
          ,out-expr))
      (defun ,in-function (stream buffer start requested eof-error-p
                           &aux (total-copied 0))
        (declare (type fd-stream stream)
                 (type index start requested total-copied)
                 (type
                  (simple-array character (#.+ansi-stream-in-buffer-length+))
                  buffer))
        (when (fd-stream-eof-forced-p stream)
          (setf (fd-stream-eof-forced-p stream) nil)
          (return-from ,in-function 0))
        (do ((instead (fd-stream-instead stream)))
            ((= (fill-pointer instead) 0)
             (setf (fd-stream-listen stream) nil))
          (setf (aref buffer (+ start total-copied)) (vector-pop instead))
          (incf total-copied)
          (when (= requested total-copied)
            (when (= (fill-pointer instead) 0)
              (setf (fd-stream-listen stream) nil))
            (return-from ,in-function total-copied)))
        (do ()
            (nil)
          (let* ((ibuf (fd-stream-ibuf stream))
                 (head (buffer-head ibuf))
                 (tail (buffer-tail ibuf))
                 (sap (buffer-sap ibuf))
                 (decode-break-reason nil))
            (declare (type index head tail))
            ;; Copy data from stream buffer into user's buffer.
            (do ((size nil nil))
                ((or (= tail head) (= requested total-copied)))
              (setf decode-break-reason
                    (block decode-break-reason
                      ,@(when (consp in-size-expr)
                          `((when (> ,(car in-size-expr) (- tail head))
                              (return))))
                      (let ((byte (sap-ref-8 sap head)))
                        (declare (ignorable byte))
                        (setq size ,(if (consp in-size-expr) (cadr in-size-expr) in-size-expr))
                        (when (> size (- tail head))
                          (return))
                        (setf (aref buffer (+ start total-copied)) ,in-expr)
                        (incf total-copied)
                        (incf head size))
                      nil))
              (setf (buffer-head ibuf) head)
              (when decode-break-reason
                ;; If we've already read some characters on when the invalid
                ;; code sequence is detected, we return immediately. The
                ;; handling of the error is deferred until the next call
                ;; (where this check will be false). This allows establishing
                ;; high-level handlers for decode errors (for example
  automatically resyncing in  comments ) .
                (when (plusp total-copied)
                  (return-from ,in-function total-copied))
                (when (stream-decoding-error-and-handle
                       stream decode-break-reason)
                  (if eof-error-p
                      (error 'end-of-file :stream stream)
                      (return-from ,in-function total-copied)))
                ;; we might have been given stuff to use instead, so
                ;; we have to return (and trust our caller to know
                ;; what to do about TOTAL-COPIED being 0).
                (return-from ,in-function total-copied)))
            (setf (buffer-head ibuf) head)
            ;; Maybe we need to refill the stream buffer.
            (cond ( ;; If was data in the stream buffer, we're done.
                   (plusp total-copied)
                   (return total-copied))
  If EOF , we 're done in another way .
                   (or (eq decode-break-reason 'eof)
                       (null (catch 'eof-input-catcher
                               (refill-input-buffer stream))))
                   (if eof-error-p
                       (error 'end-of-file :stream stream)
                       (return total-copied)))
                  ;; Otherwise we refilled the stream buffer, so fall
                  ;; through into another pass of the loop.
                  ))))
      (def-input-routine/variable-width ,in-char-function (character
                                                           ,external-format
                                                           ,in-size-expr
                                                           sap head)
        (let ((byte (sap-ref-8 sap head)))
          (declare (ignorable byte))
          ,in-expr))
      (defun ,resync-function (stream)
        (let ((ibuf (fd-stream-ibuf stream))
              size)
          (catch 'eof-input-catcher
            (loop
               (incf (buffer-head ibuf))
               (input-at-least stream ,(if (consp in-size-expr) (car in-size-expr) `(setq size ,in-size-expr)))
               (unless (block decode-break-reason
                         (let* ((sap (buffer-sap ibuf))
                                (head (buffer-head ibuf))
                                (byte (sap-ref-8 sap head)))
                           (declare (ignorable byte))
                           ,@(when (consp in-size-expr)
                               `((setq size ,(cadr in-size-expr))
                                 (input-at-least stream size)))
                           (setf head (buffer-head ibuf))
                           ,in-expr)
                         nil)
                 (return))))))
      (defun ,read-c-string-function (sap element-type)
        (declare (type system-area-pointer sap))
        (locally
            (declare (optimize (speed 3) (safety 0)))
          (let* ((stream ,name)
                 (size 0) (head 0) (byte 0) (char nil)
                 (decode-break-reason nil)
                 (length (dotimes (count (1- ARRAY-DIMENSION-LIMIT) count)
                           (setf decode-break-reason
                                 (block decode-break-reason
                                   (setf byte (sap-ref-8 sap head)
                                         size ,(if (consp in-size-expr)
                                                   (cadr in-size-expr)
                                                   in-size-expr)
                                         char ,in-expr)
                                   (incf head size)
                                   nil))
                           (when decode-break-reason
                             (c-string-decoding-error
                              ,name sap head decode-break-reason))
                           (when (zerop (char-code char))
                             (return count))))
                 (string (make-string length :element-type element-type)))
            (declare (ignorable stream)
                     (type index head length) ;; size
                     (type (unsigned-byte 8) byte)
                     (type (or null character) char)
                     (type string string))
            (setf head 0)
            (dotimes (index length string)
              (setf decode-break-reason
                    (block decode-break-reason
                      (setf byte (sap-ref-8 sap head)
                            size ,(if (consp in-size-expr)
                                      (cadr in-size-expr)
                                      in-size-expr)
                            char ,in-expr)
                      (incf head size)
                      nil))
              (when decode-break-reason
                (c-string-decoding-error
                 ,name sap head decode-break-reason))
              (setf (aref string index) char)))))

      (defun ,output-c-string-function (string)
        (declare (type simple-string string))
        (locally
            (declare (optimize (speed 3) (safety 0)))
          (let* ((length (length string))
                 (char-length (make-array (1+ length) :element-type 'index))
                 (buffer-length
                  (+ (loop for i of-type index below length
                        for byte of-type character = (aref string i)
                        for bits = (char-code byte)
                        sum (setf (aref char-length i)
                                  (the index ,out-size-expr)))
                     (let* ((byte (code-char 0))
                            (bits (char-code byte)))
                       (declare (ignorable byte bits))
                       (setf (aref char-length length)
                             (the index ,out-size-expr)))))
                 (tail 0)
                 (,n-buffer (make-array buffer-length
                                        :element-type '(unsigned-byte 8)))
                 stream)
            (declare (type index length buffer-length tail)
                     (type null stream)
                     (ignorable stream))
            (with-pinned-objects (,n-buffer)
              (let ((sap (vector-sap ,n-buffer)))
                (declare (system-area-pointer sap))
                (loop for i of-type index below length
                      for byte of-type character = (aref string i)
                      for bits = (char-code byte)
                      for size of-type index = (aref char-length i)
                      do (prog1
                             ,out-expr
                           (incf tail size)))
                (let* ((bits 0)
                       (byte (code-char bits))
                       (size (aref char-length length)))
                  (declare (ignorable bits byte size))
                  ,out-expr)))
            ,n-buffer)))

      (let ((entry (%make-external-format
                    :names ',external-format
                    :default-replacement-character ,replacement-character
                    :read-n-chars-fun #',in-function
                    :read-char-fun #',in-char-function
                    :write-n-bytes-fun #',out-function
                    ,@(mapcan #'(lambda (buffering)
                                  (list (intern (format nil "WRITE-CHAR-~A-BUFFERED-FUN" buffering) :keyword)
                                        `#',(intern (format nil format (string buffering)))))
                              '(:none :line :full))
                    :resync-fun #',resync-function
                    :bytes-for-char-fun #',size-function
                    :read-c-string-fun #',read-c-string-function
                    :write-c-string-fun #',output-c-string-function
                    :octets-to-string-fun (lambda (&rest rest)
                                            (declare (dynamic-extent rest))
                                            (apply ',octets-to-string-sym rest))
                    :string-to-octets-fun (lambda (&rest rest)
                                            (declare (dynamic-extent rest))
                                            (apply ',string-to-octets-sym rest)))))
        (dolist (ef ',external-format)
          (setf (gethash ef *external-formats*) entry))))))

;;;; utility functions (misc routines, etc)

;;; Fill in the various routine slots for the given type. INPUT-P and
;;; OUTPUT-P indicate what slots to fill. The buffering slot must be
;;; set prior to calling this routine.
(defun set-fd-stream-routines (fd-stream element-type external-format
                               input-p output-p buffer-p)
  (let* ((target-type (case element-type
                        (unsigned-byte '(unsigned-byte 8))
                        (signed-byte '(signed-byte 8))
                        (:default 'character)
                        (t element-type)))
         (character-stream-p (subtypep target-type 'character))
         (bivalent-stream-p (eq element-type :default))
         normalized-external-format
         char-size
         (bin-routine #'ill-bin)
         (bin-type nil)
         (bin-size nil)
         (cin-routine #'ill-in)
         (cin-type nil)
         (cin-size nil)
         (input-type nil)           ;calculated from bin-type/cin-type
         (input-size nil)           ;calculated from bin-size/cin-size
         (read-n-characters #'ill-in)
         (bout-routine #'ill-bout)
         (bout-type nil)
         (bout-size nil)
         (cout-routine #'ill-out)
         (cout-type nil)
         (cout-size nil)
         (output-type nil)
         (output-size nil)
         (output-bytes #'ill-bout))

    ;; Ensure that we have buffers in the desired direction(s) only,
    ;; getting new ones and dropping/resetting old ones as necessary.
    (let ((obuf (fd-stream-obuf fd-stream)))
      (if output-p
          (if obuf
              (reset-buffer obuf)
              (setf (fd-stream-obuf fd-stream) (get-buffer)))
          (when obuf
            (setf (fd-stream-obuf fd-stream) nil)
            (release-buffer obuf))))

    (let ((ibuf (fd-stream-ibuf fd-stream)))
      (if input-p
          (if ibuf
              (reset-buffer ibuf)
              (setf (fd-stream-ibuf fd-stream) (get-buffer)))
          (when ibuf
            (setf (fd-stream-ibuf fd-stream) nil)
            (release-buffer ibuf))))

    ;; FIXME: Why only for output? Why unconditionally?
    (when output-p
      (setf (fd-stream-char-pos fd-stream) 0))

    (when (and character-stream-p (eq external-format :default))
      (/show0 "/getting default external format")
      (setf external-format (default-external-format)))

    (when input-p
      (when (or (not character-stream-p) bivalent-stream-p)
        (setf (values bin-routine bin-type bin-size read-n-characters
                      char-size normalized-external-format)
              (pick-input-routine (if bivalent-stream-p '(unsigned-byte 8)
                                      target-type)
                                  external-format))
        (unless bin-routine
          (error "could not find any input routine for ~S" target-type)))
      (when character-stream-p
        (setf (values cin-routine cin-type cin-size read-n-characters
                      char-size normalized-external-format)
              (pick-input-routine target-type external-format))
        (unless cin-routine
          (error "could not find any input routine for ~S" target-type)))
      (setf (fd-stream-in fd-stream) cin-routine
            (fd-stream-bin fd-stream) bin-routine)
      ;; character type gets preferential treatment
      (setf input-size (or cin-size bin-size))
      (setf input-type (or cin-type bin-type))
      (when normalized-external-format
        (setf (fd-stream-external-format fd-stream) normalized-external-format
              (fd-stream-char-size fd-stream) char-size))
      (when (= (or cin-size 1) (or bin-size 1) 1)
        (setf (fd-stream-n-bin fd-stream) ;XXX
              (if (and character-stream-p (not bivalent-stream-p))
                  read-n-characters
                  #'fd-stream-read-n-bytes))
  Sometimes turn on fast - read - char / fast - read - byte .   Switch on
        ;; for character and (unsigned-byte 8) streams.  In these
        ;; cases, fast-read-* will read from the
        ;; ansi-stream-(c)in-buffer, saving function calls.
        ;; Otherwise, the various data-reading functions in the stream
        ;; structure will be called.
        (when (and buffer-p
                   (not bivalent-stream-p)
                   ;; temporary disable on :io streams
                   (not output-p))
          (cond (character-stream-p
                 (setf (ansi-stream-cin-buffer fd-stream)
                       (make-array +ansi-stream-in-buffer-length+
                                   :element-type 'character)))
                ((equal target-type '(unsigned-byte 8))
                 (setf (ansi-stream-in-buffer fd-stream)
                       (make-array +ansi-stream-in-buffer-length+
                                   :element-type '(unsigned-byte 8))))))))

    (when output-p
      (when (or (not character-stream-p) bivalent-stream-p)
        (setf (values bout-routine bout-type bout-size output-bytes
                      char-size normalized-external-format)
              (let ((buffering (fd-stream-buffering fd-stream)))
                (if bivalent-stream-p
                    (pick-output-routine '(unsigned-byte 8)
                                         (if (eq :line buffering)
                                             :full
                                             buffering)
                                         external-format)
                    (pick-output-routine target-type buffering external-format))))
        (unless bout-routine
          (error "could not find any output routine for ~S buffered ~S"
                 (fd-stream-buffering fd-stream)
                 target-type)))
      (when character-stream-p
        (setf (values cout-routine cout-type cout-size output-bytes
                      char-size normalized-external-format)
              (pick-output-routine target-type
                                   (fd-stream-buffering fd-stream)
                                   external-format))
        (unless cout-routine
          (error "could not find any output routine for ~S buffered ~S"
                 (fd-stream-buffering fd-stream)
                 target-type)))
      (when normalized-external-format
        (setf (fd-stream-external-format fd-stream) normalized-external-format
              (fd-stream-char-size fd-stream) char-size))
      (when character-stream-p
        (setf (fd-stream-output-bytes fd-stream) output-bytes))
      (setf (fd-stream-out fd-stream) cout-routine
            (fd-stream-bout fd-stream) bout-routine
            (fd-stream-sout fd-stream) (if (eql cout-size 1)
                                           #'fd-sout #'ill-out))
      (setf output-size (or cout-size bout-size))
      (setf output-type (or cout-type bout-type)))

    (when (and input-size output-size
               (not (eq input-size output-size)))
      (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"
             input-type input-size
             output-type output-size))
    (setf (fd-stream-element-size fd-stream)
          (or input-size output-size))

    (setf (fd-stream-element-type fd-stream)
          (cond ((equal input-type output-type)
                 input-type)
                ((null output-type)
                 input-type)
                ((null input-type)
                 output-type)
                ((subtypep input-type output-type)
                 input-type)
                ((subtypep output-type input-type)
                 output-type)
                (t
                 (error "Input type (~S) and output type (~S) are unrelated?"
                        input-type
                        output-type))))))

;;; Handles the resource-release aspects of stream closing, and marks
;;; it as closed.
(defun release-fd-stream-resources (fd-stream)
  (handler-case
      (without-interrupts
  Drop handlers first .
        (when (fd-stream-handler fd-stream)
          (remove-fd-handler (fd-stream-handler fd-stream))
          (setf (fd-stream-handler fd-stream) nil))
        ;; Disable interrupts so that a asynch unwind will not leave
        ;; us with a dangling finalizer (that would close the same
        ;; --possibly reassigned-- FD again), or a stream with a closed
  FD that appears open .
        (sb!unix:unix-close (fd-stream-fd fd-stream))
        (set-closed-flame fd-stream)
        (when (fboundp 'cancel-finalization)
          (cancel-finalization fd-stream)))
    ;; On error unwind from WITHOUT-INTERRUPTS.
    (serious-condition (e)
      (error e)))
  ;; Release all buffers. If this is undone, or interrupted,
  ;; we're still safe: buffers have finalizers of their own.
  (release-fd-stream-buffers fd-stream))

;;; Flushes the current input buffer and any supplied replacements,
;;; and returns the input buffer, and the amount of of flushed input
;;; in bytes.
(defun flush-input-buffer (stream)
  (let ((unread (length (fd-stream-instead stream))))
    (setf (fill-pointer (fd-stream-instead stream)) 0)
    (let ((ibuf (fd-stream-ibuf stream)))
      (if ibuf
          (let ((head (buffer-head ibuf))
                (tail (buffer-tail ibuf)))
            (values (reset-buffer ibuf) (- (+ unread tail) head)))
          (values nil unread)))))

(defun fd-stream-clear-input (stream)
  (flush-input-buffer stream)
  #!+win32
  (progn
    (sb!win32:fd-clear-input (fd-stream-fd stream))
    (setf (fd-stream-listen stream) nil))
  #!-win32
  (catch 'eof-input-catcher
    (loop until (sysread-may-block-p stream)
          do
          (refill-input-buffer stream)
          (reset-buffer (fd-stream-ibuf stream)))
    t))

  Handle miscellaneous operations on FD - STREAM .
(defun fd-stream-misc-routine (fd-stream operation &optional arg1 arg2)
  (declare (ignore arg2))
  (case operation
    (:listen
     (labels ((do-listen ()
                (let ((ibuf (fd-stream-ibuf fd-stream)))
                  (or (not (eql (buffer-head ibuf) (buffer-tail ibuf)))
                      (fd-stream-listen fd-stream)
                      #!+win32
                      (sb!win32:fd-listen (fd-stream-fd fd-stream))
                      #!-win32
  If the read can block , LISTEN will certainly return NIL .
                      (if (sysread-may-block-p fd-stream)
                          nil
  Otherwise select(2 ) and CL : LISTEN have slightly
  different semantics .   The former returns that an FD
                          ;; is readable when a read operation wouldn't block.
  That includes EOF .   However , LISTEN must return NIL
  at EOF .
                          (progn (catch 'eof-input-catcher
                                   ;; r-b/f too calls select, but it shouldn't
                                   ;; block as long as read can return once w/o
                                   ;; blocking
                                   (refill-input-buffer fd-stream))
  At this point either IBUF - HEAD ! = IBUF - TAIL
  and FD - STREAM - LISTEN is NIL , in which case
  we should return T , or IBUF - HEAD = =
  IBUF - TAIL and FD - STREAM - LISTEN is : EOF , in
                                 ;; which case we should return :EOF for this
                                 ;; call and all future LISTEN call on this stream.
                                 ;; Call ourselves again to determine which case
                                 ;; applies.
                                 (do-listen)))))))
       (do-listen)))
    (:unread
     (decf (buffer-head (fd-stream-ibuf fd-stream))
           (fd-stream-character-size fd-stream arg1)))
    (:close
     ;; Drop input buffers
     (setf (ansi-stream-in-index fd-stream) +ansi-stream-in-buffer-length+
           (ansi-stream-cin-buffer fd-stream) nil
           (ansi-stream-in-buffer fd-stream) nil)
     (cond (arg1
            ;; We got us an abort on our hands.
            (let ((outputp (fd-stream-obuf fd-stream))
                  (file (fd-stream-file fd-stream))
                  (orig (fd-stream-original fd-stream)))
              ;; This takes care of the important stuff -- everything
              ;; rest is cleaning up the file-system, which we cannot
              ;; do on some platforms as long as the file is open.
              (release-fd-stream-resources fd-stream)
              ;; We can't do anything unless we know what file were
              ;; dealing with, and we don't want to do anything
              ;; strange unless we were writing to the file.
              (when (and outputp file)
                (if orig
  If the original is EQ to file we are appending to
                    ;; and can just close the file without renaming.
                    (unless (eq orig file)
                      ;; We have a handle on the original, just revert.
                      (multiple-value-bind (okay err)
                          (sb!unix:unix-rename orig file)
                        ;; FIXME: Why is this a SIMPLE-STREAM-ERROR, and the
                        ;; others are SIMPLE-FILE-ERRORS? Surely they should
                        ;; all be the same?
                        (unless okay
                          (error 'simple-stream-error
                                 :format-control
                                 "~@<Couldn't restore ~S to its original contents ~
                                  from ~S while closing ~S: ~2I~_~A~:>"
                                 :format-arguments
                                 (list file orig fd-stream (strerror err))
                                 :stream fd-stream))))
                    ;; We can't restore the original, and aren't
                    ;; appending, so nuke that puppy.
                    ;;
                    ;; FIXME: This is currently the fate of superseded
                    ;; files, and according to the CLOSE spec this is
                    ;; wrong. However, there seems to be no clean way to
                    ;; do that that doesn't involve either copying the
                    ;; data (bad if the :abort resulted from a full
                    ;; disk), or renaming the old file temporarily
                    ;; (probably bad because stream opening becomes more
                    ;; racy).
                    (multiple-value-bind (okay err)
                        (sb!unix:unix-unlink file)
                      (unless okay
                        (error 'simple-file-error
                               :pathname file
                               :format-control
                               "~@<Couldn't remove ~S while closing ~S: ~2I~_~A~:>"
                               :format-arguments
                               (list file fd-stream (strerror err)))))))))
           (t
            (finish-fd-stream-output fd-stream)
            (let ((orig (fd-stream-original fd-stream)))
              (when (and orig (fd-stream-delete-original fd-stream))
                (multiple-value-bind (okay err) (sb!unix:unix-unlink orig)
                  (unless okay
                    (error 'simple-file-error
                           :pathname orig
                           :format-control
                           "~@<couldn't delete ~S while closing ~S: ~2I~_~A~:>"
                           :format-arguments
                           (list orig fd-stream (strerror err)))))))
            ;; In case of no-abort close, don't *really* close the
            ;; stream until the last moment -- the cleaning up of the
  original can be done first .
            (release-fd-stream-resources fd-stream))))
    (:clear-input
     (fd-stream-clear-input fd-stream))
    (:force-output
     (flush-output-buffer fd-stream))
    (:finish-output
     (finish-fd-stream-output fd-stream))
    (:element-type
     (fd-stream-element-type fd-stream))
    (:external-format
     (fd-stream-external-format fd-stream))
    (:interactive-p
     (plusp (the (integer 0)
              (sb!unix:unix-isatty (fd-stream-fd fd-stream)))))
    (:line-length
     80)
    (:charpos
     (fd-stream-char-pos fd-stream))
    (:file-length
     (unless (fd-stream-file fd-stream)
  This is a TYPE - ERROR because ANSI 's species FILE - LENGTH
       ;; "should signal an error of type TYPE-ERROR if stream is not
       ;; a stream associated with a file". Too bad there's no very
       ;; appropriate value for the EXPECTED-TYPE slot..
       (error 'simple-type-error
              :datum fd-stream
              :expected-type 'fd-stream
              :format-control "~S is not a stream associated with a file."
              :format-arguments (list fd-stream)))
     #!-win32
     (multiple-value-bind (okay dev ino mode nlink uid gid rdev size
                                atime mtime ctime blksize blocks)
         (sb!unix:unix-fstat (fd-stream-fd fd-stream))
       (declare (ignore ino nlink uid gid rdev
                        atime mtime ctime blksize blocks))
       (unless okay
         (simple-stream-perror "failed Unix fstat(2) on ~S" fd-stream dev))
       (if (zerop mode)
           nil
           (truncate size (fd-stream-element-size fd-stream))))
     #!+win32
     (let* ((handle (fd-stream-fd fd-stream))
            (element-size (fd-stream-element-size fd-stream)))
       (multiple-value-bind (got native-size)
           (sb!win32:get-file-size-ex handle 0)
         (if (zerop got)
             ;; Might be a block device, in which case we fall back to
             ;; a non-atomic workaround:
             (let* ((here (sb!unix:unix-lseek handle 0 sb!unix:l_incr))
                    (there (sb!unix:unix-lseek handle 0 sb!unix:l_xtnd)))
               (when (and here there)
                 (sb!unix:unix-lseek handle here sb!unix:l_set)
                 (truncate there element-size)))
             (truncate native-size element-size)))))
    (:file-string-length
     (etypecase arg1
       (character (fd-stream-character-size fd-stream arg1))
       (string (fd-stream-string-size fd-stream arg1))))
    (:file-position
     (if arg1
         (fd-stream-set-file-position fd-stream arg1)
         (fd-stream-get-file-position fd-stream)))))

;; FIXME: Think about this.
;;
;; (defun finish-fd-stream-output (fd-stream)
;;   (let ((timeout (fd-stream-timeout fd-stream)))
;;     (loop while (fd-stream-output-queue fd-stream)
         ; ; FIXME : SIGINT while waiting for a timeout will
;;        ;; cause a timeout here.
;;        do (when (and (not (serve-event timeout)) timeout)
;;             (signal-timeout 'io-timeout
;;                             :stream fd-stream
;;                             :direction :write
                              : seconds timeout ) ) ) ) )

(defun finish-fd-stream-output (stream)
  (flush-output-buffer stream)
  (do ()
      ((null (fd-stream-output-queue stream)))
    (aver (fd-stream-serve-events stream))
    (serve-all-events)))

(defun fd-stream-get-file-position (stream)
  (declare (fd-stream stream))
  (without-interrupts
    (let ((posn (sb!unix:unix-lseek (fd-stream-fd stream) 0 sb!unix:l_incr)))
      (declare (type (or (alien sb!unix:unix-offset) null) posn))
      ;; We used to return NIL for errno==ESPIPE, and signal an error
      ;; in other failure cases. However, CLHS says to return NIL if
      ;; the position cannot be determined -- so that's what we do.
      (when (integerp posn)
        ;; Adjust for buffered output: If there is any output
        ;; buffered, the *real* file position will be larger
  than reported by lseek ( ) because lseek ( ) obviously
        ;; cannot take into account output we have not sent
        ;; yet.
        (dolist (buffer (fd-stream-output-queue stream))
          (incf posn (- (buffer-tail buffer) (buffer-head buffer))))
        (let ((obuf (fd-stream-obuf stream)))
          (when obuf
            (incf posn (buffer-tail obuf))))
        ;; Adjust for unread input: If there is any input
  read from UNIX but not supplied to the user of the
        ;; stream, the *real* file position will smaller than
        ;; reported, because we want to look like the unread
        ;; stuff is still available.
        (let ((ibuf (fd-stream-ibuf stream)))
          (when ibuf
            (decf posn (- (buffer-tail ibuf) (buffer-head ibuf)))))
        ;; Divide bytes by element size.
        (truncate posn (fd-stream-element-size stream))))))

(defun fd-stream-set-file-position (stream position-spec)
  (declare (fd-stream stream))
  (check-type position-spec
              (or (alien sb!unix:unix-offset) (member nil :start :end))
              "valid file position designator")
  (tagbody
   :again
     ;; Make sure we don't have any output pending, because if we
     ;; move the file pointer before writing this stuff, it will be
     ;; written in the wrong location.
     (finish-fd-stream-output stream)
     ;; Disable interrupts so that interrupt handlers doing output
     ;; won't screw us.
     (without-interrupts
       (unless (fd-stream-output-finished-p stream)
         ;; We got interrupted and more output came our way during
         ;; the interrupt. Wrapping the FINISH-FD-STREAM-OUTPUT in
         ;; WITHOUT-INTERRUPTS gets nasty as it can signal errors,
         ;; so we prefer to do things like this...
         (go :again))
       ;; Clear out any pending input to force the next read to go to
       ;; the disk.
       (flush-input-buffer stream)
       ;; Trash cached value for listen, so that we check next time.
       (setf (fd-stream-listen stream) nil)
         ;; Now move it.
         (multiple-value-bind (offset origin)
             (case position-spec
               (:start
                (values 0 sb!unix:l_set))
               (:end
                (values 0 sb!unix:l_xtnd))
               (t
                (values (* position-spec (fd-stream-element-size stream))
                        sb!unix:l_set)))
           (declare (type (alien sb!unix:unix-offset) offset))
           (let ((posn (sb!unix:unix-lseek (fd-stream-fd stream)
                                           offset origin)))
             ;; CLHS says to return true if the file-position was set
             ;; succesfully, and NIL otherwise. We are to signal an error
             ;; only if the given position was out of bounds, and that is
  dealt with above . In times past we used to return NIL for
             ;; errno==ESPIPE, and signal an error in other cases.
             ;;
             ;; FIXME: We are still liable to signal an error if flushing
             ;; output fails.
             (return-from fd-stream-set-file-position
               (typep posn '(alien sb!unix:unix-offset))))))))


;;;; creation routines (MAKE-FD-STREAM and OPEN)

;;; Create a stream for the given Unix file descriptor.
;;;
  If INPUT is non - NIL , allow input operations . If OUTPUT is non - nil ,
  allow output operations . If neither INPUT nor OUTPUT is specified ,
;;; default to allowing input.
;;;
;;; ELEMENT-TYPE indicates the element type to use (as for OPEN).
;;;
;;; BUFFERING indicates the kind of buffering to use.
;;;
  TIMEOUT ( if true ) is the number of seconds to wait for input . If
  NIL ( the default ) , then wait forever . When we time out , we signal
;;; IO-TIMEOUT.
;;;
;;; FILE is the name of the file (will be returned by PATHNAME).
;;;
;;; NAME is used to identify the stream when printed.
;;;
;;; If SERVE-EVENTS is true, SERVE-EVENT machinery is used to
  handle blocking IO on the stream .
(defun make-fd-stream (fd
                       &key
                       (input nil input-p)
                       (output nil output-p)
                       (element-type 'base-char)
                       (buffering :full)
                       (external-format :default)
                       serve-events
                       timeout
                       file
                       original
                       delete-original
                       pathname
                       input-buffer-p
                       dual-channel-p
                       (name (if file
                                 (format nil "file ~A" file)
                                 (format nil "descriptor ~W" fd)))
                       auto-close)
  (declare (type index fd) (type (or real null) timeout)
           (type (member :none :line :full) buffering))
  (cond ((not (or input-p output-p))
         (setf input t))
        ((not (or input output))
         (error "File descriptor must be opened either for input or output.")))
  (let ((stream (%make-fd-stream :fd fd
                                 :fd-type (progn
                                            #!-win32 (sb!unix:fd-type fd)
                                            ;; KLUDGE.
                                            #!+win32 (if serve-events
                                                         :unknown
                                                         :regular))
                                 :name name
                                 :file file
                                 :original original
                                 :delete-original delete-original
                                 :pathname pathname
                                 :buffering buffering
                                 :dual-channel-p dual-channel-p
                                 :bivalent-p (eq element-type :default)
                                 :serve-events serve-events
                                 :timeout
                                 (if timeout
                                     (coerce timeout 'single-float)
                                     nil))))
    (set-fd-stream-routines stream element-type external-format
                            input output input-buffer-p)
    (when (and auto-close (fboundp 'finalize))
      (finalize stream
                (lambda ()
                  (sb!unix:unix-close fd)
                  #!+sb-show
                  (format *terminal-io* "** closed file descriptor ~W **~%"
                          fd))
                :dont-save t))
    stream))

;;; Pick a name to use for the backup file for the :IF-EXISTS
;;; :RENAME-AND-DELETE and :RENAME options.
(defun pick-backup-name (name)
  (declare (type simple-string name))
  (concatenate 'simple-string name ".bak"))

;;; Ensure that the given arg is one of the given list of valid
;;; things. Allow the user to fix any problems.
(defun ensure-one-of (item list what)
  (unless (member item list)
    (error 'simple-type-error
           :datum item
           :expected-type `(member ,@list)
           :format-control "~@<~S is ~_invalid for ~S; ~_need one of~{ ~S~}~:>"
           :format-arguments (list item what list))))

  Rename NAMESTRING to ORIGINAL . First , check whether we have write
;;; access, since we don't want to trash unwritable files even if we
;;; technically can. We return true if we succeed in renaming.
(defun rename-the-old-one (namestring original)
  (unless (sb!unix:unix-access namestring sb!unix:w_ok)
    (error "~@<The file ~2I~_~S ~I~_is not writable.~:>" namestring))
  (multiple-value-bind (okay err) (sb!unix:unix-rename namestring original)
    (if okay
        t
        (error 'simple-file-error
               :pathname namestring
               :format-control
               "~@<couldn't rename ~2I~_~S ~I~_to ~2I~_~S: ~4I~_~A~:>"
               :format-arguments (list namestring original (strerror err))))))

(defun open (filename
             &key
             (direction :input)
             (element-type 'base-char)
             (if-exists nil if-exists-given)
             (if-does-not-exist nil if-does-not-exist-given)
             (external-format :default)
  Squelch assignment warning .
             (direction direction)
             (if-does-not-exist if-does-not-exist)
             (if-exists if-exists))
  #!+sb-doc
  "Return a stream which reads from or writes to FILENAME.
  Defined keywords:
   :DIRECTION - one of :INPUT, :OUTPUT, :IO, or :PROBE
   :ELEMENT-TYPE - the type of object to read or write, default BASE-CHAR
   :IF-EXISTS - one of :ERROR, :NEW-VERSION, :RENAME, :RENAME-AND-DELETE,
                       :OVERWRITE, :APPEND, :SUPERSEDE or NIL
   :IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or NIL
  See the manual for details."

  ;; Calculate useful stuff.
  (multiple-value-bind (input output mask)
      (ecase direction
        (:input  (values   t nil sb!unix:o_rdonly))
        (:output (values nil   t sb!unix:o_wronly))
        (:io     (values   t   t sb!unix:o_rdwr))
        (:probe  (values   t nil sb!unix:o_rdonly)))
    (declare (type index mask))
    (let* (;; PATHNAME is the pathname we associate with the stream.
           (pathname (merge-pathnames filename))
           (physical (physicalize-pathname pathname))
           (truename (probe-file physical))
           ;; NAMESTRING is the native namestring we open the file with.
           (namestring (cond (truename
                              (native-namestring truename :as-file t))
                             ((or (not input)
                                  (and input (eq if-does-not-exist :create))
                                  (and (eq direction :io) (not if-does-not-exist-given)))
                              (native-namestring physical :as-file t)))))
      ;; Process if-exists argument if we are doing any output.
      (cond (output
             (unless if-exists-given
               (setf if-exists
                     (if (eq (pathname-version pathname) :newest)
                         :new-version
                         :error)))
             (ensure-one-of if-exists
                            '(:error :new-version :rename
                                     :rename-and-delete :overwrite
                                     :append :supersede nil)
                            :if-exists)
             (case if-exists
               ((:new-version :error nil)
                (setf mask (logior mask sb!unix:o_excl)))
               ((:rename :rename-and-delete)
                (setf mask (logior mask sb!unix:o_creat)))
               ((:supersede)
                (setf mask (logior mask sb!unix:o_trunc)))
               (:append
                (setf mask (logior mask sb!unix:o_append)))))
            (t
             (setf if-exists :ignore-this-arg)))

      (unless if-does-not-exist-given
        (setf if-does-not-exist
              (cond ((eq direction :input) :error)
                    ((and output
                          (member if-exists '(:overwrite :append)))
                     :error)
                    ((eq direction :probe)
                     nil)
                    (t
                     :create))))
      (ensure-one-of if-does-not-exist
                     '(:error :create nil)
                     :if-does-not-exist)
      (if (eq if-does-not-exist :create)
        (setf mask (logior mask sb!unix:o_creat)))

      (let ((original (case if-exists
                        ((:rename :rename-and-delete)
                         (pick-backup-name namestring))
                        ((:append :overwrite)
   : Provent CLOSE from deleting
                         ;; appending streams when called with :ABORT T
                         namestring)))
            (delete-original (eq if-exists :rename-and-delete))
            (mode #o666))
        (when (and original (not (eq original namestring)))
          ;; We are doing a :RENAME or :RENAME-AND-DELETE. Determine
          ;; whether the file already exists, make sure the original
          ;; file is not a directory, and keep the mode.
          (let ((exists
                 (and namestring
                      (multiple-value-bind (okay err/dev inode orig-mode)
                          (sb!unix:unix-stat namestring)
                        (declare (ignore inode)
                                 (type (or index null) orig-mode))
                        (cond
                         (okay
                          (when (and output (= (logand orig-mode #o170000)
                                               #o40000))
                            (error 'simple-file-error
                                   :pathname pathname
                                   :format-control
                                   "can't open ~S for output: is a directory"
                                   :format-arguments (list namestring)))
                          (setf mode (logand orig-mode #o777))
                          t)
                         ((eql err/dev sb!unix:enoent)
                          nil)
                         (t
                          (simple-file-perror "can't find ~S"
                                              namestring
                                              err/dev)))))))
            (unless (and exists
                         (rename-the-old-one namestring original))
              (setf original nil)
              (setf delete-original nil)
  In order to use : SUPERSEDE instead , we have to make
  sure  :  corresponds to
  IF - DOES - NOT - EXIST .  :  was set before
              ;; because of IF-EXISTS being :RENAME.
              (unless (eq if-does-not-exist :create)
                (setf mask
                      (logior (logandc2 mask sb!unix:o_creat)
                              sb!unix:o_trunc)))
              (setf if-exists :supersede))))

        ;; Now we can try the actual Unix open(2).
        (multiple-value-bind (fd errno)
            (if namestring
                (sb!unix:unix-open namestring mask mode)
                (values nil sb!unix:enoent))
          (labels ((open-error (format-control &rest format-arguments)
                     (error 'simple-file-error
                            :pathname pathname
                            :format-control format-control
                            :format-arguments format-arguments))
                   (vanilla-open-error ()
                     (simple-file-perror "error opening ~S" pathname errno)))
            (cond ((numberp fd)
                   (case direction
                     ((:input :output :io)
  For O_APPEND opened files , lseek returns 0 until first write .
                      ;; So we jump ahead here.
                      (when (eq if-exists :append)
                        (sb!unix:unix-lseek fd 0 sb!unix:l_xtnd))
                      (make-fd-stream fd
                                      :input input
                                      :output output
                                      :element-type element-type
                                      :external-format external-format
                                      :file namestring
                                      :original original
                                      :delete-original delete-original
                                      :pathname pathname
                                      :dual-channel-p nil
                                      :serve-events nil
                                      :input-buffer-p t
                                      :auto-close t))
                     (:probe
                      (let ((stream
                             (%make-fd-stream :name namestring
                                              :fd fd
                                              :pathname pathname
                                              :element-type element-type)))
                        (close stream)
                        stream))))
                  ((eql errno sb!unix:enoent)
                   (case if-does-not-exist
                     (:error (vanilla-open-error))
                     (:create
                      (open-error "~@<The path ~2I~_~S ~I~_does not exist.~:>"
                                  pathname))
                     (t nil)))
                  ((and (eql errno sb!unix:eexist) (null if-exists))
                   nil)
                  (t
                   (vanilla-open-error)))))))))

;;;; initialization

;;; the stream connected to the controlling terminal, or NIL if there is none
(defvar *tty*)

;;; the stream connected to the standard input (file descriptor 0)
(defvar *stdin*)

  the stream connected to the standard output ( file descriptor 1 )
(defvar *stdout*)

  the stream connected to the standard error output ( file descriptor 2 )
(defvar *stderr*)

  This is called when the cold load is first started up , and may also
;;; be called in an attempt to recover from nested errors.
(defun stream-cold-init-or-reset ()
  (stream-reinit)
  (setf *terminal-io* (make-synonym-stream '*tty*))
  (setf *standard-output* (make-synonym-stream '*stdout*))
  (setf *standard-input* (make-synonym-stream '*stdin*))
  (setf *error-output* (make-synonym-stream '*stderr*))
  (setf *query-io* (make-synonym-stream '*terminal-io*))
  (setf *debug-io* *query-io*)
  (setf *trace-output* *standard-output*)
  (values))

(defun stream-deinit ()
  ;; Unbind to make sure we're not accidently dealing with it
  ;; before we're ready (or after we think it's been deinitialized).
  (with-available-buffers-lock ()
    (without-package-locks
        (makunbound '*available-buffers*))))

(defun stdstream-external-format (fd outputp)
  #!-win32 (declare (ignore fd outputp))
  (let* ((keyword #!+win32 (if (and (/= fd -1)
                                    (logbitp 0 fd)
                                    (logbitp 1 fd))
                               :ucs-2
                               (if outputp
                                   (sb!win32::console-output-codepage)
                                   (sb!win32::console-input-codepage)))
                  #!-win32 (default-external-format))
         (ef (get-external-format keyword))
         (replacement (ef-default-replacement-character ef)))
    `(,keyword :replacement ,replacement)))

;;; This is called whenever a saved core is restarted.
(defun stream-reinit (&optional init-buffers-p)
  (when init-buffers-p
    (with-available-buffers-lock ()
      (aver (not (boundp '*available-buffers*)))
      (setf *available-buffers* nil)))
  (with-output-to-string (*error-output*)
    (multiple-value-bind (in out err)
        #!-win32 (values 0 1 2)
        #!+win32 (sb!win32::get-std-handles)
      (flet ((stdio-stream (handle name inputp outputp)
               (make-fd-stream
                handle
                :name name
                :input inputp
                :output outputp
                :buffering :line
                :element-type :default
                :serve-events inputp
                :external-format (stdstream-external-format handle outputp))))
        (setf *stdin*  (stdio-stream in  "standard input"    t nil))
        (setf *stdout* (stdio-stream out "standard output" nil   t))
        (setf *stderr* (stdio-stream err "standard error"  nil   t))))
    #!+win32
    (setf *tty* (make-two-way-stream *stdin* *stdout*))
    #!-win32
    (let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string))
           (tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666)))
      (if tty
          (setf *tty*
                (make-fd-stream tty :name "the terminal"
                                :input t :output t :buffering :line
                                :external-format (stdstream-external-format
                                                  tty t)
                                :serve-events (or #!-win32 t)
                                :auto-close t))
          (setf *tty* (make-two-way-stream *stdin* *stdout*))))
    (princ (get-output-stream-string *error-output*) *stderr*))
  (values))

;;;; miscellany

;;; the Unix way to beep
(defun beep (stream)
  (write-char (code-char bell-char-code) stream)
  (finish-output stream))

;;; This is kind of like FILE-POSITION, but is an internal hack used
;;; by the filesys stuff to get and set the file name.
;;;
;;; FIXME: misleading name, screwy interface
(defun file-name (stream &optional new-name)
  (when (typep stream 'fd-stream)
      (cond (new-name
             (setf (fd-stream-pathname stream) new-name)
             (setf (fd-stream-file stream)
                   (native-namestring (physicalize-pathname new-name)
                                      :as-file t))
             t)
            (t
             (fd-stream-pathname stream)))))

 more information.

 public domain. The software is in the public domain and is
 provided with absolutely no warranty. See the COPYING and CREDITS
 files for more information.

 indexes which delimit the "valid", or "active" area of the

 Buffers get allocated lazily, and are recycled by returning them
 to the *AVAILABLE-BUFFERS* list. Every buffer has it's own
 is not properly closed.

 The code aims to provide a limited form of thread and interrupt
 safety: parallel writes and reads may lose output or input, cause
 key to doing this is to read buffer state once, and update the
 state based on the read state:

 (let ((tail (buffer-tail buffer)))
   ...

 NOT

 (let ((tail (buffer-tail buffer)))
   ...
  (incf (buffer-tail buffer) n))

 CALL-WITH-SYSTEM-MUTEX because streams are low-level enough to be
 async signal safe, and in particular a C-c that brings up the
 debugger while holding the mutex would lose badly.
 Don't want to allocate & unwind before the finalizer is in place.
 Don't go for the lock if there is nothing to be had -- sure,
 is not worth the cost of locking. Also release the lock before
 allocation, since it's going to take a while.
 This is a separate buffer management function, as it wants to be
 clever about locking -- grabbing the lock just once.
 ...so, anything found?
 detach from stream
 splice to *available-buffers*
 the name of this stream
 the file this stream is for
 the backup file namestring for the old file, for :IF-EXISTS
 :RENAME or :RENAME-AND-DELETE.
 for :if-exists :rename-and-delete
 the number of bytes per element
 the type of element being transfered
 the Unix file descriptor
 controls when the output buffer is flushed
 controls whether the input buffer must be cleared before output
 (must be done for files, not for sockets, pipes and other data
 sources where input and output aren't related).  non-NIL means
 don't clear input buffer.
 character position if known -- this may run into bignums, but
 we probably should flip it into null then for efficiency's sake...
 T if serve-event is allowed when this stream blocks
 the input buffer
 the output buffer
 output flushed, but not written due to non-blocking io?
 pathname of the file this stream is opened to (returned by PATHNAME)
 fixed width, or function to call with a character
 a boolean indicating whether the stream is bivalent.  For
 internal use only.
 to output buffer(s) of stream.
 Copy bytes from THING to buffers.
 us, we don't want to accidentally increment tail
 beyond buffer-length.
 something, or be even full.
 Later copies should always have an empty buffer, since
 they are freshly flushed, but if another thread is
 stomping on the same buffer that might not be the case.
 Flush the current output buffer of the stream, ensuring that the
 new buffer is empty. Returns (for convenience) the new output
 queued output we try to write the buffer immediately -- otherwise
 we queue it for later.
 Buffer is already empty -- just ensure that is is
 There is already stuff on the queue -- go directly
 there.
 Try a non-blocking write, if SERVE-EVENT is allowed, queue
 whatever is left over. Otherwise wait until we can write.
 Complete write -- we can use the same buffer.
 Partial write -- update buffer status and
 queue or wait.
 if interrupted on win32, just try again
 Helper for FLUSH-OUTPUT-BUFFER -- returns the new buffer.
 Important: before putting the buffer on queue, give the stream
 a new one. If we get an interrupt and unwind losing the buffer
 would be bad.
 This is called by the FD-HANDLER for the stream when output is
 possible.
 Complete write, see if we can do another right
 away, or remove the handler if we're done.
 Partial write. Update buffer status and requeue.
 We tried to do multiple writes, and finally our
 Try to write THING directly to STREAM without buffering, if
 possible. If direct write doesn't happen, buffer.
 Complete write -- done!
 Partial write -- buffer the rest.
 Could not write -- buffer or error.
 right thing is to support a low-level non-stream like IO layer,
 akin to java.nio.
 output routines and related noise
 common idioms for reporting low-level stream and file problems
 Returning true goes into end of file handling, false will enter another
 round of input buffer filling followed by re-entering character decode.
 If we're reading and writing on the same file, flush buffered
 input and rewind file position accordingly.
 FIXME: Why this here? Doesn't seem necessary.
 FIXME: Why this here? Doesn't seem necessary.
 Define output routines that output numbers SIZE bytes long for the
 given bufferings. Use BODY to do the actual output.
 FIXME: is this used anywhere any more?
 the routine to use to output a string. If the stream is
 unbuffered, slam the string down the file descriptor, otherwise
 use OUTPUT-RAW-BYTES to buffer the string. Update charpos by
 checking to see where the last newline was.
 one is the canonical name.
 Can be nil for fixed-width formats.
 We indirect through symbols in these functions so that a
 developer working on the octets code can easily redefine things
 and use the new function definition without redefining the
 external format as well.  The slots above don't do any
 indirection because a developer working with those slots would be
 redefining the external format anyway.
 Find an output routine to use given the type and buffering. Return
 as multiple values the routine, the real type transfered, and the
 number of bytes per element.
 explosion.

 input routines and related noise
 a list of all available input routines. Each element is a list of
 the element-type input, the function name, and the number of bytes
 per element.
 system call implementing this operation fails.

 It is "may" instead of "would" because "would" is not quite
 correct on win32.  However, none of the places that use it require
 further assurance than "may" versus "will definitely not".
 This answers T at EOF on win32, I think.
 If the read would block wait (using SERVE-EVENT) till input is available,
 then fill the input buffer, and return the number of bytes read. Throws
 Check for blocking input before touching the stream if we are to
 read(). Regular files should never block, so we can elide the check.
 These (:CLOSED-FLAME and :READ-ERROR) tags are here so what
 we can signal errors outside the WITHOUT-INTERRUPTS.
 This tag is here so we can unwind outside the WITHOUT-INTERRUPTS
 to wait for input if read tells us EWOULDBLOCK.
 Since the read should not block, we'll disable the
 interrupts here, so that we don't accidentally unwind and
 leave the stream in an inconsistent state.
 Execute the nlx outside without-interrupts to ensure the
 resulting thunk is stack-allocatable.
 fast path normal cases
 Check the buffer: if it is null, then someone has closed
 the stream from underneath us. This is not ment to fix
 multithreaded races, but to deal with interrupt handlers
 closing the stream.
 Buffer is empty, but not at yet reset -- make it so.
 Buffer has things in it, but they are not at the
 head -- move them there.
 Make sure there are at least BYTES number of bytes in the input
 buffer. Keep calling REFILL-INPUT-BUFFER until that condition is met.
 a macro to wrap around all input routines to handle EOF-ERROR noise
 STREAM-IN routine for reading a string char
 Find an input routine to use given the type. Return as multiple
 values the routine, the real type transfered, and the number of
 bytes per element (and for character types string input routine).
 FIXME: let's do it the hard way, then (but ignore things like
 endianness, efficiency, and the necessary coupling between these

 Note that this blocks in UNIX-READ. It is generally used where
 there is a definite amount of reading to be done, so blocking
 isn't too problematical.
 Copy data from stream buffer into user's buffer.
 Maybe we need to refill the stream buffer.
 If there were enough data in the stream buffer, we're done.
 Otherwise we refilled the stream buffer, so fall
 through into another pass of the loop.
 FIXME: Rename
 STRING bounds have already been checked.
 Copy data from stream buffer into user's buffer.
 If we've already read some characters on when the invalid
 code sequence is detected, we return immediately. The
 handling of the error is deferred until the next call
 (where this check will be false). This allows establishing
 high-level handlers for decode errors (for example
 we might have been given stuff to use instead, so
 we have to return (and trust our caller to know
 what to do about TOTAL-COPIED being 0).
 Maybe we need to refill the stream buffer.
 If was data in the stream buffer, we're done.
 Otherwise we refilled the stream buffer, so fall
 through into another pass of the loop.
 size
 utility functions (misc routines, etc)
 Fill in the various routine slots for the given type. INPUT-P and
 OUTPUT-P indicate what slots to fill. The buffering slot must be
 set prior to calling this routine.
calculated from bin-type/cin-type
calculated from bin-size/cin-size
 Ensure that we have buffers in the desired direction(s) only,
 getting new ones and dropping/resetting old ones as necessary.
 FIXME: Why only for output? Why unconditionally?
 character type gets preferential treatment
XXX
 for character and (unsigned-byte 8) streams.  In these
 cases, fast-read-* will read from the
 ansi-stream-(c)in-buffer, saving function calls.
 Otherwise, the various data-reading functions in the stream
 structure will be called.
 temporary disable on :io streams
 Handles the resource-release aspects of stream closing, and marks
 it as closed.
 Disable interrupts so that a asynch unwind will not leave
 us with a dangling finalizer (that would close the same
 --possibly reassigned-- FD again), or a stream with a closed
 On error unwind from WITHOUT-INTERRUPTS.
 Release all buffers. If this is undone, or interrupted,
 we're still safe: buffers have finalizers of their own.
 Flushes the current input buffer and any supplied replacements,
 and returns the input buffer, and the amount of of flushed input
 in bytes.
 is readable when a read operation wouldn't block.
 r-b/f too calls select, but it shouldn't
 block as long as read can return once w/o
 blocking
 which case we should return :EOF for this
 call and all future LISTEN call on this stream.
 Call ourselves again to determine which case
 applies.
 Drop input buffers
 We got us an abort on our hands.
 This takes care of the important stuff -- everything
 rest is cleaning up the file-system, which we cannot
 do on some platforms as long as the file is open.
 We can't do anything unless we know what file were
 dealing with, and we don't want to do anything
 strange unless we were writing to the file.
 and can just close the file without renaming.
 We have a handle on the original, just revert.
 FIXME: Why is this a SIMPLE-STREAM-ERROR, and the
 others are SIMPLE-FILE-ERRORS? Surely they should
 all be the same?
 We can't restore the original, and aren't
 appending, so nuke that puppy.

 FIXME: This is currently the fate of superseded
 files, and according to the CLOSE spec this is
 wrong. However, there seems to be no clean way to
 do that that doesn't involve either copying the
 data (bad if the :abort resulted from a full
 disk), or renaming the old file temporarily
 (probably bad because stream opening becomes more
 racy).
 In case of no-abort close, don't *really* close the
 stream until the last moment -- the cleaning up of the
 "should signal an error of type TYPE-ERROR if stream is not
 a stream associated with a file". Too bad there's no very
 appropriate value for the EXPECTED-TYPE slot..
 Might be a block device, in which case we fall back to
 a non-atomic workaround:
 FIXME: Think about this.

 (defun finish-fd-stream-output (fd-stream)
   (let ((timeout (fd-stream-timeout fd-stream)))
     (loop while (fd-stream-output-queue fd-stream)
 ; FIXME : SIGINT while waiting for a timeout will
        ;; cause a timeout here.
        do (when (and (not (serve-event timeout)) timeout)
             (signal-timeout 'io-timeout
                             :stream fd-stream
                             :direction :write
 We used to return NIL for errno==ESPIPE, and signal an error
 in other failure cases. However, CLHS says to return NIL if
 the position cannot be determined -- so that's what we do.
 Adjust for buffered output: If there is any output
 buffered, the *real* file position will be larger
 cannot take into account output we have not sent
 yet.
 Adjust for unread input: If there is any input
 stream, the *real* file position will smaller than
 reported, because we want to look like the unread
 stuff is still available.
 Divide bytes by element size.
 Make sure we don't have any output pending, because if we
 move the file pointer before writing this stuff, it will be
 written in the wrong location.
 Disable interrupts so that interrupt handlers doing output
 won't screw us.
 We got interrupted and more output came our way during
 the interrupt. Wrapping the FINISH-FD-STREAM-OUTPUT in
 WITHOUT-INTERRUPTS gets nasty as it can signal errors,
 so we prefer to do things like this...
 Clear out any pending input to force the next read to go to
 the disk.
 Trash cached value for listen, so that we check next time.
 Now move it.
 CLHS says to return true if the file-position was set
 succesfully, and NIL otherwise. We are to signal an error
 only if the given position was out of bounds, and that is
 errno==ESPIPE, and signal an error in other cases.

 FIXME: We are still liable to signal an error if flushing
 output fails.
 creation routines (MAKE-FD-STREAM and OPEN)
 Create a stream for the given Unix file descriptor.

 default to allowing input.

 ELEMENT-TYPE indicates the element type to use (as for OPEN).

 BUFFERING indicates the kind of buffering to use.

 IO-TIMEOUT.

 FILE is the name of the file (will be returned by PATHNAME).

 NAME is used to identify the stream when printed.

 If SERVE-EVENTS is true, SERVE-EVENT machinery is used to
 KLUDGE.
 Pick a name to use for the backup file for the :IF-EXISTS
 :RENAME-AND-DELETE and :RENAME options.
 Ensure that the given arg is one of the given list of valid
 things. Allow the user to fix any problems.
 access, since we don't want to trash unwritable files even if we
 technically can. We return true if we succeed in renaming.
 Calculate useful stuff.
 PATHNAME is the pathname we associate with the stream.
 NAMESTRING is the native namestring we open the file with.
 Process if-exists argument if we are doing any output.
 appending streams when called with :ABORT T
 We are doing a :RENAME or :RENAME-AND-DELETE. Determine
 whether the file already exists, make sure the original
 file is not a directory, and keep the mode.
 because of IF-EXISTS being :RENAME.
 Now we can try the actual Unix open(2).
 So we jump ahead here.
 initialization
 the stream connected to the controlling terminal, or NIL if there is none
 the stream connected to the standard input (file descriptor 0)
 be called in an attempt to recover from nested errors.
 Unbind to make sure we're not accidently dealing with it
 before we're ready (or after we think it's been deinitialized).
 This is called whenever a saved core is restarted.
 miscellany
 the Unix way to beep
 This is kind of like FILE-POSITION, but is an internal hack used
 by the filesys stuff to get and set the file name.

 FIXME: misleading name, screwy interface
  streams for UNIX file descriptors

  This software is part of the SBCL system . See the README file for
  This software is derived from the CMU CL system , which was
  written at Carnegie Mellon University and released into the

(in-package "SB!IMPL")

  BUFFER
  Streams hold BUFFER objects , which contain a SAP , size of the
  memory area the SAP stands for ( LENGTH bytes ) , and HEAD and TAIL
  memory . HEAD is inclusive , TAIL is exclusive .
  finalizer , to take care of releasing the SAP memory when a stream
  interleaved IO , etc -- but they should not corrupt memory . The
    ( setf ( buffer - tail buffer ) ( + tail n ) ) )

(declaim (inline buffer-sap buffer-length buffer-head buffer-tail
                 (setf buffer-head) (setf buffer-tail)))
(defstruct (buffer (:constructor %make-buffer (sap length)))
  (sap (missing-arg) :type system-area-pointer :read-only t)
  (length (missing-arg) :type index :read-only t)
  (head 0 :type index)
  (tail 0 :type index))

(defvar *available-buffers* ()
  #!+sb-doc
  "List of available buffers.")

(defvar *available-buffers-lock* (sb!thread:make-mutex
                                  :name "lock for *AVAILABLE-BUFFERS*")
  #!+sb-doc
  "Mutex for access to *AVAILABLE-BUFFERS*.")

(defmacro with-available-buffers-lock ((&optional) &body body)
  `(sb!thread::with-system-mutex (*available-buffers-lock*)
     ,@body))

(defconstant +bytes-per-buffer+ (* 4 1024)
  #!+sb-doc
  "Default number of bytes per buffer.")

(defun alloc-buffer (&optional (size +bytes-per-buffer+))
  (without-interrupts
    (let* ((sap (allocate-system-memory size))
           (buffer (%make-buffer sap size)))
      (when (zerop (sap-int sap))
        (error "Could not allocate ~D bytes for buffer." size))
      (finalize buffer (lambda ()
                         (deallocate-system-memory sap size))
                :dont-save t)
      buffer)))

(defun get-buffer ()
  another thread might just release one before we get it , but that
  (if *available-buffers*
      (or (with-available-buffers-lock ()
            (pop *available-buffers*))
          (alloc-buffer))
      (alloc-buffer)))

(declaim (inline reset-buffer))
(defun reset-buffer (buffer)
  (setf (buffer-head buffer) 0
        (buffer-tail buffer) 0)
  buffer)

(defun release-buffer (buffer)
  (reset-buffer buffer)
  (with-available-buffers-lock ()
    (push buffer *available-buffers*)))

(defun release-fd-stream-buffers (fd-stream)
  (let ((ibuf (fd-stream-ibuf fd-stream))
        (obuf (fd-stream-obuf fd-stream))
        (queue (loop for item in (fd-stream-output-queue fd-stream)
                       when (buffer-p item)
                       collect (reset-buffer item))))
    (when ibuf
      (push (reset-buffer ibuf) queue))
    (when obuf
      (push (reset-buffer obuf) queue))
    (when queue
      (setf (fd-stream-ibuf fd-stream) nil
            (fd-stream-obuf fd-stream) nil
            (fd-stream-output-queue fd-stream) nil)
      (with-available-buffers-lock ()
        (setf *available-buffers* (nconc queue *available-buffers*))))))

  the FD - STREAM structure

(defstruct (fd-stream
            (:constructor %make-fd-stream)
            (:conc-name fd-stream-)
            (:predicate fd-stream-p)
            (:include ansi-stream
                      (misc #'fd-stream-misc-routine))
            (:copier nil))

  (name nil)
  (file nil)
  (original nil :type (or simple-string null))
  (element-size 1 :type index)
  (element-type 'base-char)
  (fd -1 :type #!-win32 fixnum #!+win32 sb!vm:signed-word)
  What do we know about the FD ?
  (fd-type :unknown :type keyword)
  (buffering :full :type (member :full :line :none))
  (dual-channel-p nil)
  (char-pos nil :type (or unsigned-byte null))
  T if input is waiting on FD . : EOF if we hit EOF .
  (listen nil :type (member nil t :eof))
  (serve-events nil :type boolean)

  (instead (make-array 0 :element-type 'character :adjustable t :fill-pointer t) :type (array character (*)))
  (ibuf nil :type (or buffer null))
  (eof-forced-p nil :type (member t nil))

  (obuf nil :type (or buffer null))

  (output-queue nil)
  (handler nil)
  timeout specified for this stream as seconds or NIL if none
  (timeout nil :type (or single-float null))
  (pathname nil :type (or pathname null))
  Not :  , because we want to match CHAR - SIZE !
  (external-format :latin-1)
  (char-size 1 :type (or fixnum function))
  (output-bytes #'ill-out :type function)
  (bivalent-p nil :type boolean))
(def!method print-object ((fd-stream fd-stream) stream)
  (declare (type stream stream))
  (print-unreadable-object (fd-stream stream :type t :identity t)
    (format stream "for ~S" (fd-stream-name fd-stream))))

  CORE OUTPUT FUNCTIONS

  Buffer the section of THING delimited by START and END by copying
(defun buffer-output (stream thing start end)
  (declare (index start end))
  (when (< end start)
    (error ":END before :START!"))
  (when (> end start)
    (flet ((copy-to-buffer (buffer tail count)
             (declare (buffer buffer) (index tail count))
             (aver (plusp count))
             (let ((sap (buffer-sap buffer)))
               (etypecase thing
                 (system-area-pointer
                  (system-area-ub8-copy thing start sap tail count))
                 ((simple-unboxed-array (*))
                  (copy-ub8-to-system-area thing start sap tail count))))
  Not INCF ! If another thread has moved tail from under
             (setf (buffer-tail buffer) (+ count tail))
             (incf start count)))
      (tagbody
  First copy is special : the buffer may already contain
         (let* ((obuf (fd-stream-obuf stream))
                (tail (buffer-tail obuf))
                (space (- (buffer-length obuf) tail)))
           (when (plusp space)
             (copy-to-buffer obuf tail (min space (- end start)))
             (go :more-output-p)))
       :flush-and-fill
         (let* ((obuf (flush-output-buffer stream))
                (tail (buffer-tail obuf))
                (space (- (buffer-length obuf) tail)))
           (copy-to-buffer obuf tail (min space (- end start))))
       :more-output-p
         (when (> end start)
           (go :flush-and-fill))))))

  buffer -- which may or may not be EQ to the old one . If the is no
(defun flush-output-buffer (stream)
  (let ((obuf (fd-stream-obuf stream)))
    (when obuf
      (let ((head (buffer-head obuf))
            (tail (buffer-tail obuf)))
        (cond ((eql head tail)
  set to zero as well .
               (reset-buffer obuf))
              ((fd-stream-output-queue stream)
               (aver (< head tail))
               (%queue-and-replace-output-buffer stream))
              (t
               (aver (< head tail))
               (synchronize-stream-output stream)
               (loop
                 (let ((length (- tail head)))
                   (multiple-value-bind (count errno)
                       (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap obuf)
                                           head length)
                     (flet ((queue-or-wait ()
                              (if (fd-stream-serve-events stream)
                                  (return (%queue-and-replace-output-buffer stream))
                                  (or (wait-until-fd-usable (fd-stream-fd stream) :output
                                                            (fd-stream-timeout stream)
                                                            nil)
                                      (signal-timeout 'io-timeout
                                                      :stream stream
                                                      :direction :output
                                                      :seconds (fd-stream-timeout stream))))))
                        (cond ((eql count length)
                               (return (reset-buffer obuf)))
                              (count
                               (incf head count)
                               (setf (buffer-head obuf) head)
                               (queue-or-wait))
                              #!-win32
                              ((eql errno sb!unix:ewouldblock)
  Blocking , queue or wair .
                               (queue-or-wait))
                              #!+win32 ((eql errno sb!unix:eintr))
                              (t
                               (simple-stream-perror "Couldn't write to ~s"
                                                     stream errno)))))))))))))

(defun %queue-and-replace-output-buffer (stream)
  (aver (fd-stream-serve-events stream))
  (let ((queue (fd-stream-output-queue stream))
        (later (list (or (fd-stream-obuf stream) (bug "Missing obuf."))))
        (new (get-buffer)))
  is relatively OK , but having the same buffer in two places
    (setf (fd-stream-obuf stream) new)
    (cond (queue
           (nconc queue later))
          (t
           (setf (fd-stream-output-queue stream) later)))
    (unless (fd-stream-handler stream)
      (setf (fd-stream-handler stream)
            (add-fd-handler (fd-stream-fd stream)
                            :output
                            (lambda (fd)
                              (declare (ignore fd))
                              (write-output-from-queue stream)))))
    new))

(defun write-output-from-queue (stream)
  (aver (fd-stream-serve-events stream))
  (synchronize-stream-output stream)
  (let (not-first-p)
    (tagbody
     :pop-buffer
       (let* ((buffer (pop (fd-stream-output-queue stream)))
              (head (buffer-head buffer))
              (length (- (buffer-tail buffer) head)))
         (declare (index head length))
         (aver (>= length 0))
         (multiple-value-bind (count errno)
             (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap buffer)
                                 head length)
           (cond ((eql count length)
                  (release-buffer buffer)
                  (cond ((fd-stream-output-queue stream)
                         (setf not-first-p t)
                         (go :pop-buffer))
                        (t
                         (let ((handler (fd-stream-handler stream)))
                           (aver handler)
                           (setf (fd-stream-handler stream) nil)
                           (remove-fd-handler handler)))))
                 (count
                  (aver (< count length))
  Do not use INCF ! Another thread might have moved head .
                  (setf (buffer-head buffer) (+ head count))
                  (push buffer (fd-stream-output-queue stream)))
                 (not-first-p
  luck ran out .  .
                  (push buffer (fd-stream-output-queue stream)))
                 (t
  Could not write on the first try at all !
                  #!+win32
                  (simple-stream-perror "Couldn't write to ~S." stream errno)
                  #!-win32
                  (if (= errno sb!unix:ewouldblock)
                      (bug "Unexpected blocking in WRITE-OUTPUT-FROM-QUEUE.")
                      (simple-stream-perror "Couldn't write to ~S"
                                            stream errno))))))))
  nil)

(defun write-or-buffer-output (stream thing start end)
  (declare (index start end))
  (cond ((fd-stream-output-queue stream)
         (buffer-output stream thing start end))
        ((< end start)
         (error ":END before :START!"))
        ((> end start)
         (let ((length (- end start)))
           (synchronize-stream-output stream)
           (multiple-value-bind (count errno)
               (sb!unix:unix-write (fd-stream-fd stream) thing start length)
             (cond ((eql count length)
                    )
                   (count
                    (aver (< count length))
                    (buffer-output stream thing (+ start count) end))
                   (t
                    #!+win32
                    (simple-stream-perror "couldn't write to ~s" stream errno)
                    #!-win32
                    (if (= errno sb!unix:ewouldblock)
                        (buffer-output stream thing start end)
                        (simple-stream-perror "couldn't write to ~s" stream errno)))))))))

  Deprecated -- can go away after 1.1 or so . Deprecated because
  this is not something we want to export . Nikodemus thinks the
(declaim (inline output-raw-bytes))
(define-deprecated-function :late "1.0.8.16" output-raw-bytes write-sequence
    (stream thing &optional start end)
  (write-or-buffer-output stream thing (or start 0) (or end (length thing))))


(defvar *output-routines* ()
  #!+sb-doc
  "List of all available output routines. Each element is a list of the
  element-type output, the kind of buffering, the function name, and the number
  of bytes per element.")

(defun simple-stream-perror (note-format stream errno)
  (error 'simple-stream-error
         :stream stream
         :format-control "~@<~?: ~2I~_~A~:>"
         :format-arguments (list note-format (list stream) (strerror errno))))
(defun simple-file-perror (note-format pathname errno)
  (error 'simple-file-error
         :pathname pathname
         :format-control "~@<~?: ~2I~_~A~:>"
         :format-arguments
         (list note-format (list pathname) (strerror errno))))

(defun c-string-encoding-error (external-format code)
  (error 'c-string-encoding-error
         :external-format external-format
         :code code))
(defun c-string-decoding-error (external-format sap offset count)
  (error 'c-string-decoding-error
         :external-format external-format
         :octets (sap-ref-octets sap offset count)))

(defun stream-decoding-error-and-handle (stream octet-count)
  (restart-case
      (error 'stream-decoding-error
             :external-format (stream-external-format stream)
             :stream stream
             :octets (let ((buffer (fd-stream-ibuf stream)))
                       (sap-ref-octets (buffer-sap buffer)
                                       (buffer-head buffer)
                                       octet-count)))
    (attempt-resync ()
      :report (lambda (stream)
                (format stream
                        "~@<Attempt to resync the stream at a ~
                        character boundary and continue.~@:>"))
      (fd-stream-resync stream)
      nil)
    (force-end-of-file ()
      :report (lambda (stream)
                (format stream "~@<Force an end of file.~@:>"))
      (setf (fd-stream-eof-forced-p stream) t))
    (input-replacement (string)
      :report (lambda (stream)
                (format stream "~@<Use string as replacement input, ~
                               attempt to resync at a character ~
                               boundary and continue.~@:>"))
      :interactive (lambda ()
                     (format *query-io* "~@<Enter a string: ~@:>")
                     (finish-output *query-io*)
                     (list (read *query-io*)))
      (let ((string (reverse (string string)))
            (instead (fd-stream-instead stream)))
        (dotimes (i (length string))
          (vector-push-extend (char string i) instead))
        (fd-stream-resync stream)
        (when (> (length string) 0)
          (setf (fd-stream-listen stream) t)))
      nil)))

(defun stream-encoding-error-and-handle (stream code)
  (restart-case
      (error 'stream-encoding-error
             :external-format (stream-external-format stream)
             :stream stream
             :code code)
    (output-nothing ()
      :report (lambda (stream)
                (format stream "~@<Skip output of this character.~@:>"))
      (throw 'output-nothing nil))
    (output-replacement (string)
      :report (lambda (stream)
                (format stream "~@<Output replacement string.~@:>"))
      :interactive (lambda ()
                     (format *query-io* "~@<Enter a string: ~@:>")
                     (finish-output *query-io*)
                     (list (read *query-io*)))
      (let ((string (string string)))
        (fd-sout stream (string string) 0 (length string)))
      (throw 'output-nothing nil))))

(defun external-format-encoding-error (stream code)
  (if (streamp stream)
      (stream-encoding-error-and-handle stream code)
      (c-string-encoding-error stream code)))

(defun synchronize-stream-output (stream)
  (unless (fd-stream-dual-channel-p stream)
    (let ((adjust (nth-value 1 (flush-input-buffer stream))))
      (unless (eql 0 adjust)
        (sb!unix:unix-lseek (fd-stream-fd stream) (- adjust) sb!unix:l_incr)))))

(defun fd-stream-output-finished-p (stream)
  (let ((obuf (fd-stream-obuf stream)))
    (or (not obuf)
        (and (zerop (buffer-tail obuf))
             (not (fd-stream-output-queue stream))))))

(defmacro output-wrapper/variable-width ((stream size buffering restart)
                                         &body body)
  (let ((stream-var (gensym "STREAM")))
    `(let* ((,stream-var ,stream)
            (obuf (fd-stream-obuf ,stream-var))
            (tail (buffer-tail obuf))
            (size ,size))
      ,(unless (eq (car buffering) :none)
         `(when (<= (buffer-length obuf) (+ tail size))
            (setf obuf (flush-output-buffer ,stream-var)
                  tail (buffer-tail obuf))))
      ,(unless (eq (car buffering) :none)
         `(synchronize-stream-output ,stream-var))
      ,(if restart
           `(catch 'output-nothing
              ,@body
              (setf (buffer-tail obuf) (+ tail size)))
           `(progn
             ,@body
             (setf (buffer-tail obuf) (+ tail size))))
      ,(ecase (car buffering)
         (:none
          `(flush-output-buffer ,stream-var))
         (:line
          `(when (eql byte #\Newline)
             (flush-output-buffer ,stream-var)))
         (:full))
    (values))))

(defmacro output-wrapper ((stream size buffering restart) &body body)
  (let ((stream-var (gensym "STREAM")))
    `(let* ((,stream-var ,stream)
            (obuf (fd-stream-obuf ,stream-var))
            (tail (buffer-tail obuf)))
      ,(unless (eq (car buffering) :none)
         `(when (<= (buffer-length obuf) (+ tail ,size))
            (setf obuf (flush-output-buffer ,stream-var)
                  tail (buffer-tail obuf))))
      ,(unless (eq (car buffering) :none)
         `(synchronize-stream-output ,stream-var))
      ,(if restart
           `(catch 'output-nothing
              ,@body
              (setf (buffer-tail obuf) (+ tail ,size)))
           `(progn
             ,@body
             (setf (buffer-tail obuf) (+ tail ,size))))
      ,(ecase (car buffering)
         (:none
          `(flush-output-buffer ,stream-var))
         (:line
          `(when (eql byte #\Newline)
             (flush-output-buffer ,stream-var)))
         (:full))
    (values))))

(defmacro def-output-routines/variable-width
    ((name-fmt size restart external-format &rest bufferings)
     &body body)
  (declare (optimize (speed 1)))
  (cons 'progn
        (mapcar
            (lambda (buffering)
              (let ((function
                     (intern (format nil name-fmt (string (car buffering))))))
                `(progn
                   (defun ,function (stream byte)
                     (declare (ignorable byte))
                     (output-wrapper/variable-width (stream ,size ,buffering ,restart)
                       ,@body))
                   (setf *output-routines*
                         (nconc *output-routines*
                                ',(mapcar
                                   (lambda (type)
                                     (list type
                                           (car buffering)
                                           function
                                           1
                                           external-format))
                                   (cdr buffering)))))))
            bufferings)))

(defmacro def-output-routines ((name-fmt size restart &rest bufferings)
                               &body body)
  (declare (optimize (speed 1)))
  (cons 'progn
        (mapcar
            (lambda (buffering)
              (let ((function
                     (intern (format nil name-fmt (string (car buffering))))))
                `(progn
                   (defun ,function (stream byte)
                     (output-wrapper (stream ,size ,buffering ,restart)
                       ,@body))
                   (setf *output-routines*
                         (nconc *output-routines*
                                ',(mapcar
                                   (lambda (type)
                                     (list type
                                           (car buffering)
                                           function
                                           size
                                           nil))
                                   (cdr buffering)))))))
            bufferings)))

(def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
                      1
                      t
                      (:none character)
                      (:line character)
                      (:full character))
  (if (eql byte #\Newline)
      (setf (fd-stream-char-pos stream) 0)
      (incf (fd-stream-char-pos stream)))
  (setf (sap-ref-8 (buffer-sap obuf) tail)
        (char-code byte)))

(def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"
                      1
                      nil
                      (:none (unsigned-byte 8))
                      (:full (unsigned-byte 8)))
  (setf (sap-ref-8 (buffer-sap obuf) tail)
        byte))

(def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED"
                      1
                      nil
                      (:none (signed-byte 8))
                      (:full (signed-byte 8)))
  (setf (signed-sap-ref-8 (buffer-sap obuf) tail)
        byte))

(def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED"
                      2
                      nil
                      (:none (unsigned-byte 16))
                      (:full (unsigned-byte 16)))
  (setf (sap-ref-16 (buffer-sap obuf) tail)
        byte))

(def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED"
                      2
                      nil
                      (:none (signed-byte 16))
                      (:full (signed-byte 16)))
  (setf (signed-sap-ref-16 (buffer-sap obuf) tail)
        byte))

(def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED"
                      4
                      nil
                      (:none (unsigned-byte 32))
                      (:full (unsigned-byte 32)))
  (setf (sap-ref-32 (buffer-sap obuf) tail)
        byte))

(def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED"
                      4
                      nil
                      (:none (signed-byte 32))
                      (:full (signed-byte 32)))
  (setf (signed-sap-ref-32 (buffer-sap obuf) tail)
        byte))

#+#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or))
(progn
  (def-output-routines ("OUTPUT-UNSIGNED-LONG-LONG-~A-BUFFERED"
                        8
                        nil
                        (:none (unsigned-byte 64))
                        (:full (unsigned-byte 64)))
    (setf (sap-ref-64 (buffer-sap obuf) tail)
          byte))
  (def-output-routines ("OUTPUT-SIGNED-LONG-LONG-~A-BUFFERED"
                        8
                        nil
                        (:none (signed-byte 64))
                        (:full (signed-byte 64)))
    (setf (signed-sap-ref-64 (buffer-sap obuf) tail)
          byte)))

(defun fd-sout (stream thing start end)
  (declare (type fd-stream stream) (type string thing))
  (let ((start (or start 0))
        (end (or end (length (the vector thing)))))
    (declare (fixnum start end))
    (let ((last-newline
           (string-dispatch (simple-base-string
                             #!+sb-unicode
                             (simple-array character (*))
                             string)
               thing
             (position #\newline thing :from-end t
                       :start start :end end))))
      (if (and (typep thing 'base-string)
               (eq (fd-stream-external-format-keyword stream) :latin-1))
          (ecase (fd-stream-buffering stream)
            (:full
             (buffer-output stream thing start end))
            (:line
             (buffer-output stream thing start end)
             (when last-newline
               (flush-output-buffer stream)))
            (:none
             (write-or-buffer-output stream thing start end)))
          (ecase (fd-stream-buffering stream)
            (:full (funcall (fd-stream-output-bytes stream)
                            stream thing nil start end))
            (:line (funcall (fd-stream-output-bytes stream)
                            stream thing last-newline start end))
            (:none (funcall (fd-stream-output-bytes stream)
                            stream thing t start end))))
      (if last-newline
          (setf (fd-stream-char-pos stream) (- end last-newline 1))
          (incf (fd-stream-char-pos stream) (- end start))))))

(defstruct (external-format
             (:constructor %make-external-format)
             (:conc-name ef-)
             (:predicate external-format-p)
             (:copier %copy-external-format))
  All the names that can refer to this external format .   The first
  (names (missing-arg) :type list :read-only t)
  (default-replacement-character (missing-arg) :type character)
  (read-n-chars-fun (missing-arg) :type function)
  (read-char-fun (missing-arg) :type function)
  (write-n-bytes-fun (missing-arg) :type function)
  (write-char-none-buffered-fun (missing-arg) :type function)
  (write-char-line-buffered-fun (missing-arg) :type function)
  (write-char-full-buffered-fun (missing-arg) :type function)
  (resync-fun nil :type (or function null))
  (bytes-for-char-fun (missing-arg) :type function)
  (read-c-string-fun (missing-arg) :type function)
  (write-c-string-fun (missing-arg) :type function)
  (octets-to-string-fun (missing-arg) :type function)
  (string-to-octets-fun (missing-arg) :type function))

(defun ef-char-size (ef-entry)
  (if (variable-width-external-format-p ef-entry)
      (bytes-for-char-fun ef-entry)
      (funcall (bytes-for-char-fun ef-entry) #\x)))

(defun wrap-external-format-functions (external-format fun)
  (let ((result (%copy-external-format external-format)))
    (macrolet ((frob (accessor)
                 `(setf (,accessor result) (funcall fun (,accessor result)))))
      (frob ef-read-n-chars-fun)
      (frob ef-read-char-fun)
      (frob ef-write-n-bytes-fun)
      (frob ef-write-char-none-buffered-fun)
      (frob ef-write-char-line-buffered-fun)
      (frob ef-write-char-full-buffered-fun)
      (frob ef-resync-fun)
      (frob ef-bytes-for-char-fun)
      (frob ef-read-c-string-fun)
      (frob ef-write-c-string-fun)
      (frob ef-octets-to-string-fun)
      (frob ef-string-to-octets-fun))
    result))

(defvar *external-formats* (make-hash-table)
  #!+sb-doc
  "Hashtable of all available external formats. The table maps from
  external-format names to EXTERNAL-FORMAT structures.")

(defun get-external-format (external-format)
  (flet ((keyword-external-format (keyword)
           (declare (type keyword keyword))
           (gethash keyword *external-formats*))
         (replacement-handlerify (entry replacement)
           (when entry
             (wrap-external-format-functions
              entry
              (lambda (fun)
                (and fun
                     (lambda (&rest rest)
                       (declare (dynamic-extent rest))
                       (handler-bind
                           ((stream-decoding-error
                             (lambda (c)
                               (declare (ignore c))
                               (invoke-restart 'input-replacement replacement)))
                            (stream-encoding-error
                             (lambda (c)
                               (declare (ignore c))
                               (invoke-restart 'output-replacement replacement)))
                            (octets-encoding-error
                             (lambda (c) (use-value replacement c)))
                            (octet-decoding-error
                             (lambda (c) (use-value replacement c))))
                         (apply fun rest)))))))))
    (typecase external-format
      (keyword (keyword-external-format external-format))
      ((cons keyword)
       (let ((entry (keyword-external-format (car external-format)))
             (replacement (getf (cdr external-format) :replacement)))
         (if replacement
             (replacement-handlerify entry replacement)
             entry))))))

(defun get-external-format-or-lose (external-format)
  (or (get-external-format external-format)
      (error "Undefined external-format: ~S" external-format)))

(defun external-format-keyword (external-format)
  (typecase external-format
    (keyword external-format)
    ((cons keyword) (car external-format))))

(defun fd-stream-external-format-keyword (stream)
  (external-format-keyword (fd-stream-external-format stream)))

(defun canonize-external-format (external-format entry)
  (typecase external-format
    (keyword (first (ef-names entry)))
    ((cons keyword) (cons (first (ef-names entry)) (rest external-format)))))

(defun pick-output-routine (type buffering &optional external-format)
  (when (subtypep type 'character)
    (let ((entry (get-external-format-or-lose external-format)))
      (return-from pick-output-routine
        (values (ecase buffering
                  (:none (ef-write-char-none-buffered-fun entry))
                  (:line (ef-write-char-line-buffered-fun entry))
                  (:full (ef-write-char-full-buffered-fun entry)))
                'character
                1
                (ef-write-n-bytes-fun entry)
                (ef-char-size entry)
                (canonize-external-format external-format entry)))))
  (dolist (entry *output-routines*)
    (when (and (subtypep type (first entry))
               (eq buffering (second entry))
               (or (not (fifth entry))
                   (eq external-format (fifth entry))))
      (return-from pick-output-routine
        (values (symbol-function (third entry))
                (first entry)
                (fourth entry)))))
   : dealing with the buffering here leads to excessive code
   : also see comments in PICK - INPUT - ROUTINE
  ARB (  )
        if (subtypep type `(unsigned-byte ,i))
        do (return-from pick-output-routine
             (values
              (ecase buffering
                (:none
                 (lambda (stream byte)
                   (output-wrapper (stream (/ i 8) (:none) nil)
                     (loop for j from 0 below (/ i 8)
                           do (setf (sap-ref-8 (buffer-sap obuf)
                                               (+ j tail))
                                    (ldb (byte 8 (- i 8 (* j 8))) byte))))))
                (:full
                 (lambda (stream byte)
                   (output-wrapper (stream (/ i 8) (:full) nil)
                     (loop for j from 0 below (/ i 8)
                           do (setf (sap-ref-8 (buffer-sap obuf)
                                               (+ j tail))
                                    (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
              `(unsigned-byte ,i)
              (/ i 8))))
  ARB (  )
        if (subtypep type `(signed-byte ,i))
        do (return-from pick-output-routine
             (values
              (ecase buffering
                (:none
                 (lambda (stream byte)
                   (output-wrapper (stream (/ i 8) (:none) nil)
                     (loop for j from 0 below (/ i 8)
                           do (setf (sap-ref-8 (buffer-sap obuf)
                                               (+ j tail))
                                    (ldb (byte 8 (- i 8 (* j 8))) byte))))))
                (:full
                 (lambda (stream byte)
                   (output-wrapper (stream (/ i 8) (:full) nil)
                     (loop for j from 0 below (/ i 8)
                           do (setf (sap-ref-8 (buffer-sap obuf)
                                               (+ j tail))
                                    (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
              `(signed-byte ,i)
              (/ i 8)))))


(defvar *input-routines* ())

  Return whether a primitive partial read operation on STREAM 's FD
  would ( probably ) block .   Signal a ` simple - stream - error ' if the
(defun sysread-may-block-p (stream)
  #!+win32
  (not (sb!win32:fd-listen (fd-stream-fd stream)))
  #!-win32
  (not (sb!unix:unix-simple-poll (fd-stream-fd stream) :input 0)))

  to EOF - INPUT - CATCHER if the eof was reached .
(defun refill-input-buffer (stream)
  (dx-let ((fd (fd-stream-fd stream))
           (errno 0)
           (count 0))
    (tagbody
       #!+win32
       (go :main)

  serve events : if the FD is blocking , we do n't want to try an uninterruptible
       (if (and (neq :regular (fd-stream-fd-type stream))
                (sysread-may-block-p stream))
           (go :wait-for-input)
           (go :main))
     :closed-flame
       (closed-flame stream)
     :read-error
       (simple-stream-perror "couldn't read from ~S" stream errno)
     :wait-for-input
       (unless (wait-until-fd-usable fd :input (fd-stream-timeout stream)
                                     (fd-stream-serve-events stream))
         (signal-timeout 'io-timeout
                         :stream stream
                         :direction :input
                         :seconds (fd-stream-timeout stream)))
     :main

       ((lambda (return-reason)
          (ecase return-reason
            ((:wait-for-input) (go #!-win32 :wait-for-input #!+win32 :main))
            ((:closed-flame)   (go :closed-flame))
            ((:read-error)     (go :read-error))))
        (without-interrupts
          (block nil
            (prog1 nil
              (let* ((ibuf (or (fd-stream-ibuf stream) (return :closed-flame)))
                     (sap (buffer-sap ibuf))
                     (length (buffer-length ibuf))
                     (head (buffer-head ibuf))
                     (tail (buffer-tail ibuf)))
                (declare (index length head tail)
                         (inline sb!unix:unix-read))
                (unless (zerop head)
                  (cond ((eql head tail)
                         (setf head 0
                               tail 0)
                         (reset-buffer ibuf))
                        (t
                         (let ((n (- tail head)))
                           (system-area-ub8-copy sap head sap 0 n)
                           (setf head 0
                                 (buffer-head ibuf) head
                                 tail n
                                 (buffer-tail ibuf) tail)))))
                (setf (fd-stream-listen stream) nil)
                (setf (values count errno)
                      (sb!unix:unix-read fd (sap+ sap tail) (- length tail)))
                (cond ((null count)
                       (if (eql errno
                                #!+win32 sb!unix:eintr
                                #!-win32 sb!unix:ewouldblock)
                           (return :wait-for-input)
                           (return :read-error)))
                      ((zerop count)
                       (setf (fd-stream-listen stream) :eof)
                       (/show0 "THROWing EOF-INPUT-CATCHER")
                       (throw 'eof-input-catcher nil))
                      (t
  Success ! ( Do not use INCF , for sake of other threads . )
                       (setf (buffer-tail ibuf) (+ count tail))))))))))
    count))

(defmacro input-at-least (stream bytes)
  (let ((stream-var (gensym "STREAM"))
        (bytes-var (gensym "BYTES"))
        (buffer-var (gensym "IBUF")))
    `(let* ((,stream-var ,stream)
            (,bytes-var ,bytes)
            (,buffer-var (fd-stream-ibuf ,stream-var)))
       (loop
         (when (>= (- (buffer-tail ,buffer-var)
                      (buffer-head ,buffer-var))
                   ,bytes-var)
           (return))
         (refill-input-buffer ,stream-var)))))

(defmacro input-wrapper/variable-width ((stream bytes eof-error eof-value)
                                        &body read-forms)
  (let ((stream-var (gensym "STREAM"))
        (retry-var (gensym "RETRY"))
        (element-var (gensym "ELT")))
    `(let* ((,stream-var ,stream)
            (ibuf (fd-stream-ibuf ,stream-var))
            (size nil))
       (block use-instead
         (when (fd-stream-eof-forced-p ,stream-var)
           (setf (fd-stream-eof-forced-p ,stream-var) nil)
           (return-from use-instead
             (eof-or-lose ,stream-var ,eof-error ,eof-value)))
         (let ((,element-var nil)
               (decode-break-reason nil))
           (do ((,retry-var t))
               ((not ,retry-var))
             (if (> (length (fd-stream-instead ,stream-var)) 0)
                 (let* ((instead (fd-stream-instead ,stream-var))
                        (result (vector-pop instead))
                        (pointer (fill-pointer instead)))
                   (when (= pointer 0)
                     (setf (fd-stream-listen ,stream-var) nil))
                   (return-from use-instead result))
                 (unless
                     (catch 'eof-input-catcher
                       (setf decode-break-reason
                             (block decode-break-reason
                               (input-at-least ,stream-var ,(if (consp bytes)
                                                                (car bytes)
                                                                `(setq size ,bytes)))
                               (let* ((byte (sap-ref-8 (buffer-sap ibuf) (buffer-head ibuf))))
                                 (declare (ignorable byte))
                                 ,@(when (consp bytes)
                                     `((let ((sap (buffer-sap ibuf))
                                             (head (buffer-head ibuf)))
                                         (declare (ignorable sap head))
                                         (setq size ,(cadr bytes))
                                         (input-at-least ,stream-var size))))
                                 (setq ,element-var (locally ,@read-forms))
                                 (setq ,retry-var nil))
                               nil))
                       (when decode-break-reason
                         (when (stream-decoding-error-and-handle
                                stream decode-break-reason)
                           (setq ,retry-var nil)
                           (throw 'eof-input-catcher nil)))
                       t)
                   (let ((octet-count (- (buffer-tail ibuf)
                                         (buffer-head ibuf))))
                     (when (or (zerop octet-count)
                               (and (not ,element-var)
                                    (not decode-break-reason)
                                    (stream-decoding-error-and-handle
                                     stream octet-count)))
                       (setq ,retry-var nil))))))
           (cond (,element-var
                  (incf (buffer-head ibuf) size)
                  ,element-var)
                 (t
                  (eof-or-lose ,stream-var ,eof-error ,eof-value))))))))

(defmacro input-wrapper ((stream bytes eof-error eof-value) &body read-forms)
  (let ((stream-var (gensym "STREAM"))
        (element-var (gensym "ELT")))
    `(let* ((,stream-var ,stream)
            (ibuf (fd-stream-ibuf ,stream-var)))
       (if (> (length (fd-stream-instead ,stream-var)) 0)
           (bug "INSTEAD not empty in INPUT-WRAPPER for ~S" ,stream-var)
           (let ((,element-var
                  (catch 'eof-input-catcher
                    (input-at-least ,stream-var ,bytes)
                    (locally ,@read-forms))))
             (cond (,element-var
                    (incf (buffer-head (fd-stream-ibuf ,stream-var)) ,bytes)
                    ,element-var)
                   (t
                    (eof-or-lose ,stream-var ,eof-error ,eof-value))))))))

(defmacro def-input-routine/variable-width (name
                                            (type external-format size sap head)
                                            &rest body)
  `(progn
     (defun ,name (stream eof-error eof-value)
       (input-wrapper/variable-width (stream ,size eof-error eof-value)
         (let ((,sap (buffer-sap ibuf))
               (,head (buffer-head ibuf)))
           ,@body)))
     (setf *input-routines*
           (nconc *input-routines*
                  (list (list ',type ',name 1 ',external-format))))))

(defmacro def-input-routine (name
                             (type size sap head)
                             &rest body)
  `(progn
     (defun ,name (stream eof-error eof-value)
       (input-wrapper (stream ,size eof-error eof-value)
         (let ((,sap (buffer-sap ibuf))
               (,head (buffer-head ibuf)))
           ,@body)))
     (setf *input-routines*
           (nconc *input-routines*
                  (list (list ',type ',name ',size nil))))))

(def-input-routine input-character
                   (character 1 sap head)
  (code-char (sap-ref-8 sap head)))

  STREAM - IN routine for reading an unsigned 8 bit number
(def-input-routine input-unsigned-8bit-byte
                   ((unsigned-byte 8) 1 sap head)
  (sap-ref-8 sap head))

  STREAM - IN routine for reading a signed 8 bit number
(def-input-routine input-signed-8bit-number
                   ((signed-byte 8) 1 sap head)
  (signed-sap-ref-8 sap head))

  STREAM - IN routine for reading an unsigned 16 bit number
(def-input-routine input-unsigned-16bit-byte
                   ((unsigned-byte 16) 2 sap head)
  (sap-ref-16 sap head))

  STREAM - IN routine for reading a signed 16 bit number
(def-input-routine input-signed-16bit-byte
                   ((signed-byte 16) 2 sap head)
  (signed-sap-ref-16 sap head))

  STREAM - IN routine for reading a unsigned 32 bit number
(def-input-routine input-unsigned-32bit-byte
                   ((unsigned-byte 32) 4 sap head)
  (sap-ref-32 sap head))

  STREAM - IN routine for reading a signed 32 bit number
(def-input-routine input-signed-32bit-byte
                   ((signed-byte 32) 4 sap head)
  (signed-sap-ref-32 sap head))

#+#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or))
(progn
  (def-input-routine input-unsigned-64bit-byte
      ((unsigned-byte 64) 8 sap head)
    (sap-ref-64 sap head))
  (def-input-routine input-signed-64bit-byte
      ((signed-byte 64) 8 sap head)
    (signed-sap-ref-64 sap head)))

(defun pick-input-routine (type &optional external-format)
  (when (subtypep type 'character)
    (let ((entry (get-external-format-or-lose external-format)))
      (return-from pick-input-routine
        (values (ef-read-char-fun entry)
                'character
                1
                (ef-read-n-chars-fun entry)
                (ef-char-size entry)
                (canonize-external-format external-format entry)))))
  (dolist (entry *input-routines*)
    (when (and (subtypep type (first entry))
               (or (not (fourth entry))
                   (eq external-format (fourth entry))))
      (return-from pick-input-routine
        (values (symbol-function (second entry))
                (first entry)
                (third entry)))))
  and the output routines ) .   -- CSR , 2004 - 02 - 09
  ARB ( well ,  really )
        if (subtypep type `(unsigned-byte ,i))
        do (return-from pick-input-routine
             (values
              (lambda (stream eof-error eof-value)
                (input-wrapper (stream (/ i 8) eof-error eof-value)
                  (let ((sap (buffer-sap ibuf))
                        (head (buffer-head ibuf)))
                    (loop for j from 0 below (/ i 8)
                          with result = 0
                          do (setf result
                                   (+ (* 256 result)
                                      (sap-ref-8 sap (+ head j))))
                          finally (return result)))))
              `(unsigned-byte ,i)
              (/ i 8))))
  ARB ( well ,  really )
        if (subtypep type `(signed-byte ,i))
        do (return-from pick-input-routine
             (values
              (lambda (stream eof-error eof-value)
                (input-wrapper (stream (/ i 8) eof-error eof-value)
                  (let ((sap (buffer-sap ibuf))
                        (head (buffer-head ibuf)))
                    (loop for j from 0 below (/ i 8)
                          with result = 0
                          do (setf result
                                   (+ (* 256 result)
                                      (sap-ref-8 sap (+ head j))))
                          finally (return (if (logbitp (1- i) result)
                                              (dpb result (byte i 0) -1)
                                              result))))))
              `(signed-byte ,i)
              (/ i 8)))))

  the N - BIN method for FD - STREAMs
(defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p
                               &aux (total-copied 0))
  (declare (type fd-stream stream))
  (declare (type index start requested total-copied))
  (aver (= (length (fd-stream-instead stream)) 0))
  (do ()
      (nil)
    (let* ((remaining-request (- requested total-copied))
           (ibuf (fd-stream-ibuf stream))
           (head (buffer-head ibuf))
           (tail (buffer-tail ibuf))
           (available (- tail head))
           (n-this-copy (min remaining-request available))
           (this-start (+ start total-copied))
           (this-end (+ this-start n-this-copy))
           (sap (buffer-sap ibuf)))
      (declare (type index remaining-request head tail available))
      (declare (type index n-this-copy))
      (%byte-blt sap head buffer this-start this-end)
      (incf (buffer-head ibuf) n-this-copy)
      (incf total-copied n-this-copy)
             (eql total-copied requested)
             (return total-copied))
  If EOF , we 're done in another way .
             (null (catch 'eof-input-catcher (refill-input-buffer stream)))
             (if eof-error-p
                 (error 'end-of-file :stream stream)
                 (return total-copied)))
            ))))

(defun fd-stream-resync (stream)
  (let ((entry (get-external-format (fd-stream-external-format stream))))
    (when entry
      (funcall (ef-resync-fun entry) stream))))

(defun get-fd-stream-character-sizer (stream)
  (let ((entry (get-external-format (fd-stream-external-format stream))))
    (when entry
      (ef-bytes-for-char-fun entry))))

(defun fd-stream-character-size (stream char)
  (let ((sizer (get-fd-stream-character-sizer stream)))
    (when sizer (funcall sizer char))))

(defun fd-stream-string-size (stream string)
  (let ((sizer (get-fd-stream-character-sizer stream)))
    (when sizer
      (loop for char across string summing (funcall sizer char)))))

(defun find-external-format (external-format)
  (when external-format
    (get-external-format external-format)))

(defun variable-width-external-format-p (ef-entry)
  (and ef-entry (not (null (ef-resync-fun ef-entry)))))

(defun bytes-for-char-fun (ef-entry)
  (if ef-entry (ef-bytes-for-char-fun ef-entry) (constantly 1)))

(defmacro define-unibyte-mapping-external-format
    (canonical-name (&rest other-names) &body exceptions)
  (let ((->code-name (symbolicate canonical-name '->code-mapper))
        (code->-name (symbolicate 'code-> canonical-name '-mapper))
        (get-bytes-name (symbolicate 'get- canonical-name '-bytes))
        (string->-name (symbolicate 'string-> canonical-name))
        (define-string*-name (symbolicate 'define- canonical-name '->string*))
        (string*-name (symbolicate canonical-name '->string*))
        (define-string-name (symbolicate 'define- canonical-name '->string))
        (string-name (symbolicate canonical-name '->string))
        (->string-aref-name (symbolicate canonical-name '->string-aref)))
    `(progn
       (define-unibyte-mapper ,->code-name ,code->-name
         ,@exceptions)
       (declaim (inline ,get-bytes-name))
       (defun ,get-bytes-name (string pos)
         (declare (optimize speed (safety 0))
                  (type simple-string string)
                  (type array-range pos))
         (get-latin-bytes #',code->-name ,canonical-name string pos))
       (defun ,string->-name (string sstart send null-padding)
         (declare (optimize speed (safety 0))
                  (type simple-string string)
                  (type array-range sstart send))
         (values (string->latin% string sstart send #',get-bytes-name null-padding)))
       (defmacro ,define-string*-name (accessor type)
         (declare (ignore type))
         (let ((name (make-od-name ',string*-name accessor)))
           `(progn
              (defun ,name (string sstart send array astart aend)
                (,(make-od-name 'latin->string* accessor)
                  string sstart send array astart aend #',',->code-name)))))
       (instantiate-octets-definition ,define-string*-name)
       (defmacro ,define-string-name (accessor type)
         (declare (ignore type))
         (let ((name (make-od-name ',string-name accessor)))
           `(progn
              (defun ,name (array astart aend)
                (,(make-od-name 'latin->string accessor)
                  array astart aend #',',->code-name)))))
       (instantiate-octets-definition ,define-string-name)
       (define-unibyte-external-format ,canonical-name ,other-names
         (let ((octet (,code->-name bits)))
           (if octet
               (setf (sap-ref-8 sap tail) octet)
               (external-format-encoding-error stream bits)))
         (let ((code (,->code-name byte)))
           (if code
               (code-char code)
               (return-from decode-break-reason 1)))
         ,->string-aref-name
         ,string->-name))))

(defmacro define-unibyte-external-format
    (canonical-name (&rest other-names)
     out-form in-form octets-to-string-symbol string-to-octets-symbol)
  `(define-external-format/variable-width (,canonical-name ,@other-names)
     t #\? 1
     ,out-form
     1
     ,in-form
     ,octets-to-string-symbol
     ,string-to-octets-symbol))

(defmacro define-external-format/variable-width
    (external-format output-restart replacement-character
     out-size-expr out-expr in-size-expr in-expr
     octets-to-string-sym string-to-octets-sym)
  (let* ((name (first external-format))
         (out-function (symbolicate "OUTPUT-BYTES/" name))
         (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" (string name)))
         (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name))
         (in-char-function (symbolicate "INPUT-CHAR/" name))
         (resync-function (symbolicate "RESYNC/" name))
         (size-function (symbolicate "BYTES-FOR-CHAR/" name))
         (read-c-string-function (symbolicate "READ-FROM-C-STRING/" name))
         (output-c-string-function (symbolicate "OUTPUT-TO-C-STRING/" name))
         (n-buffer (gensym "BUFFER")))
    `(progn
      (defun ,size-function (byte)
        (declare (ignorable byte))
        ,out-size-expr)
      (defun ,out-function (stream string flush-p start end)
        (let ((start (or start 0))
              (end (or end (length string))))
          (declare (type index start end))
          (synchronize-stream-output stream)
          (unless (<= 0 start end (length string))
            (sequence-bounding-indices-bad-error string start end))
          (do ()
              ((= end start))
            (let ((obuf (fd-stream-obuf stream)))
              (string-dispatch (simple-base-string
                                #!+sb-unicode (simple-array character (*))
                                string)
                  string
                (let ((len (buffer-length obuf))
                      (sap (buffer-sap obuf))
                      (tail (buffer-tail obuf)))
                  (declare (type index tail)
                           (optimize (safety 0)))
                  (,@(if output-restart
                         `(catch 'output-nothing)
                         `(progn))
                     (do* ()
                          ((or (= start end) (< (- len tail) 4)))
                       (let* ((byte (aref string start))
                              (bits (char-code byte))
                              (size ,out-size-expr))
                         ,out-expr
                         (incf tail size)
                         (setf (buffer-tail obuf) tail)
                         (incf start)))
                     (go flush))
  Exited via CATCH : skip the current character .
                  (incf start))))
           flush
            (when (< start end)
              (flush-output-buffer stream)))
          (when flush-p
            (flush-output-buffer stream))))
      (def-output-routines/variable-width (,format
                                           ,out-size-expr
                                           ,output-restart
                                           ,external-format
                                           (:none character)
                                           (:line character)
                                           (:full character))
          (if (eql byte #\Newline)
              (setf (fd-stream-char-pos stream) 0)
              (incf (fd-stream-char-pos stream)))
        (let ((bits (char-code byte))
              (sap (buffer-sap obuf))
              (tail (buffer-tail obuf)))
          ,out-expr))
      (defun ,in-function (stream buffer start requested eof-error-p
                           &aux (total-copied 0))
        (declare (type fd-stream stream)
                 (type index start requested total-copied)
                 (type
                  (simple-array character (#.+ansi-stream-in-buffer-length+))
                  buffer))
        (when (fd-stream-eof-forced-p stream)
          (setf (fd-stream-eof-forced-p stream) nil)
          (return-from ,in-function 0))
        (do ((instead (fd-stream-instead stream)))
            ((= (fill-pointer instead) 0)
             (setf (fd-stream-listen stream) nil))
          (setf (aref buffer (+ start total-copied)) (vector-pop instead))
          (incf total-copied)
          (when (= requested total-copied)
            (when (= (fill-pointer instead) 0)
              (setf (fd-stream-listen stream) nil))
            (return-from ,in-function total-copied)))
        (do ()
            (nil)
          (let* ((ibuf (fd-stream-ibuf stream))
                 (head (buffer-head ibuf))
                 (tail (buffer-tail ibuf))
                 (sap (buffer-sap ibuf))
                 (decode-break-reason nil))
            (declare (type index head tail))
            (do ((size nil nil))
                ((or (= tail head) (= requested total-copied)))
              (setf decode-break-reason
                    (block decode-break-reason
                      ,@(when (consp in-size-expr)
                          `((when (> ,(car in-size-expr) (- tail head))
                              (return))))
                      (let ((byte (sap-ref-8 sap head)))
                        (declare (ignorable byte))
                        (setq size ,(if (consp in-size-expr) (cadr in-size-expr) in-size-expr))
                        (when (> size (- tail head))
                          (return))
                        (setf (aref buffer (+ start total-copied)) ,in-expr)
                        (incf total-copied)
                        (incf head size))
                      nil))
              (setf (buffer-head ibuf) head)
              (when decode-break-reason
  automatically resyncing in  comments ) .
                (when (plusp total-copied)
                  (return-from ,in-function total-copied))
                (when (stream-decoding-error-and-handle
                       stream decode-break-reason)
                  (if eof-error-p
                      (error 'end-of-file :stream stream)
                      (return-from ,in-function total-copied)))
                (return-from ,in-function total-copied)))
            (setf (buffer-head ibuf) head)
                   (plusp total-copied)
                   (return total-copied))
  If EOF , we 're done in another way .
                   (or (eq decode-break-reason 'eof)
                       (null (catch 'eof-input-catcher
                               (refill-input-buffer stream))))
                   (if eof-error-p
                       (error 'end-of-file :stream stream)
                       (return total-copied)))
                  ))))
      (def-input-routine/variable-width ,in-char-function (character
                                                           ,external-format
                                                           ,in-size-expr
                                                           sap head)
        (let ((byte (sap-ref-8 sap head)))
          (declare (ignorable byte))
          ,in-expr))
      (defun ,resync-function (stream)
        (let ((ibuf (fd-stream-ibuf stream))
              size)
          (catch 'eof-input-catcher
            (loop
               (incf (buffer-head ibuf))
               (input-at-least stream ,(if (consp in-size-expr) (car in-size-expr) `(setq size ,in-size-expr)))
               (unless (block decode-break-reason
                         (let* ((sap (buffer-sap ibuf))
                                (head (buffer-head ibuf))
                                (byte (sap-ref-8 sap head)))
                           (declare (ignorable byte))
                           ,@(when (consp in-size-expr)
                               `((setq size ,(cadr in-size-expr))
                                 (input-at-least stream size)))
                           (setf head (buffer-head ibuf))
                           ,in-expr)
                         nil)
                 (return))))))
      (defun ,read-c-string-function (sap element-type)
        (declare (type system-area-pointer sap))
        (locally
            (declare (optimize (speed 3) (safety 0)))
          (let* ((stream ,name)
                 (size 0) (head 0) (byte 0) (char nil)
                 (decode-break-reason nil)
                 (length (dotimes (count (1- ARRAY-DIMENSION-LIMIT) count)
                           (setf decode-break-reason
                                 (block decode-break-reason
                                   (setf byte (sap-ref-8 sap head)
                                         size ,(if (consp in-size-expr)
                                                   (cadr in-size-expr)
                                                   in-size-expr)
                                         char ,in-expr)
                                   (incf head size)
                                   nil))
                           (when decode-break-reason
                             (c-string-decoding-error
                              ,name sap head decode-break-reason))
                           (when (zerop (char-code char))
                             (return count))))
                 (string (make-string length :element-type element-type)))
            (declare (ignorable stream)
                     (type (unsigned-byte 8) byte)
                     (type (or null character) char)
                     (type string string))
            (setf head 0)
            (dotimes (index length string)
              (setf decode-break-reason
                    (block decode-break-reason
                      (setf byte (sap-ref-8 sap head)
                            size ,(if (consp in-size-expr)
                                      (cadr in-size-expr)
                                      in-size-expr)
                            char ,in-expr)
                      (incf head size)
                      nil))
              (when decode-break-reason
                (c-string-decoding-error
                 ,name sap head decode-break-reason))
              (setf (aref string index) char)))))

      (defun ,output-c-string-function (string)
        (declare (type simple-string string))
        (locally
            (declare (optimize (speed 3) (safety 0)))
          (let* ((length (length string))
                 (char-length (make-array (1+ length) :element-type 'index))
                 (buffer-length
                  (+ (loop for i of-type index below length
                        for byte of-type character = (aref string i)
                        for bits = (char-code byte)
                        sum (setf (aref char-length i)
                                  (the index ,out-size-expr)))
                     (let* ((byte (code-char 0))
                            (bits (char-code byte)))
                       (declare (ignorable byte bits))
                       (setf (aref char-length length)
                             (the index ,out-size-expr)))))
                 (tail 0)
                 (,n-buffer (make-array buffer-length
                                        :element-type '(unsigned-byte 8)))
                 stream)
            (declare (type index length buffer-length tail)
                     (type null stream)
                     (ignorable stream))
            (with-pinned-objects (,n-buffer)
              (let ((sap (vector-sap ,n-buffer)))
                (declare (system-area-pointer sap))
                (loop for i of-type index below length
                      for byte of-type character = (aref string i)
                      for bits = (char-code byte)
                      for size of-type index = (aref char-length i)
                      do (prog1
                             ,out-expr
                           (incf tail size)))
                (let* ((bits 0)
                       (byte (code-char bits))
                       (size (aref char-length length)))
                  (declare (ignorable bits byte size))
                  ,out-expr)))
            ,n-buffer)))

      (let ((entry (%make-external-format
                    :names ',external-format
                    :default-replacement-character ,replacement-character
                    :read-n-chars-fun #',in-function
                    :read-char-fun #',in-char-function
                    :write-n-bytes-fun #',out-function
                    ,@(mapcan #'(lambda (buffering)
                                  (list (intern (format nil "WRITE-CHAR-~A-BUFFERED-FUN" buffering) :keyword)
                                        `#',(intern (format nil format (string buffering)))))
                              '(:none :line :full))
                    :resync-fun #',resync-function
                    :bytes-for-char-fun #',size-function
                    :read-c-string-fun #',read-c-string-function
                    :write-c-string-fun #',output-c-string-function
                    :octets-to-string-fun (lambda (&rest rest)
                                            (declare (dynamic-extent rest))
                                            (apply ',octets-to-string-sym rest))
                    :string-to-octets-fun (lambda (&rest rest)
                                            (declare (dynamic-extent rest))
                                            (apply ',string-to-octets-sym rest)))))
        (dolist (ef ',external-format)
          (setf (gethash ef *external-formats*) entry))))))


(defun set-fd-stream-routines (fd-stream element-type external-format
                               input-p output-p buffer-p)
  (let* ((target-type (case element-type
                        (unsigned-byte '(unsigned-byte 8))
                        (signed-byte '(signed-byte 8))
                        (:default 'character)
                        (t element-type)))
         (character-stream-p (subtypep target-type 'character))
         (bivalent-stream-p (eq element-type :default))
         normalized-external-format
         char-size
         (bin-routine #'ill-bin)
         (bin-type nil)
         (bin-size nil)
         (cin-routine #'ill-in)
         (cin-type nil)
         (cin-size nil)
         (read-n-characters #'ill-in)
         (bout-routine #'ill-bout)
         (bout-type nil)
         (bout-size nil)
         (cout-routine #'ill-out)
         (cout-type nil)
         (cout-size nil)
         (output-type nil)
         (output-size nil)
         (output-bytes #'ill-bout))

    (let ((obuf (fd-stream-obuf fd-stream)))
      (if output-p
          (if obuf
              (reset-buffer obuf)
              (setf (fd-stream-obuf fd-stream) (get-buffer)))
          (when obuf
            (setf (fd-stream-obuf fd-stream) nil)
            (release-buffer obuf))))

    (let ((ibuf (fd-stream-ibuf fd-stream)))
      (if input-p
          (if ibuf
              (reset-buffer ibuf)
              (setf (fd-stream-ibuf fd-stream) (get-buffer)))
          (when ibuf
            (setf (fd-stream-ibuf fd-stream) nil)
            (release-buffer ibuf))))

    (when output-p
      (setf (fd-stream-char-pos fd-stream) 0))

    (when (and character-stream-p (eq external-format :default))
      (/show0 "/getting default external format")
      (setf external-format (default-external-format)))

    (when input-p
      (when (or (not character-stream-p) bivalent-stream-p)
        (setf (values bin-routine bin-type bin-size read-n-characters
                      char-size normalized-external-format)
              (pick-input-routine (if bivalent-stream-p '(unsigned-byte 8)
                                      target-type)
                                  external-format))
        (unless bin-routine
          (error "could not find any input routine for ~S" target-type)))
      (when character-stream-p
        (setf (values cin-routine cin-type cin-size read-n-characters
                      char-size normalized-external-format)
              (pick-input-routine target-type external-format))
        (unless cin-routine
          (error "could not find any input routine for ~S" target-type)))
      (setf (fd-stream-in fd-stream) cin-routine
            (fd-stream-bin fd-stream) bin-routine)
      (setf input-size (or cin-size bin-size))
      (setf input-type (or cin-type bin-type))
      (when normalized-external-format
        (setf (fd-stream-external-format fd-stream) normalized-external-format
              (fd-stream-char-size fd-stream) char-size))
      (when (= (or cin-size 1) (or bin-size 1) 1)
              (if (and character-stream-p (not bivalent-stream-p))
                  read-n-characters
                  #'fd-stream-read-n-bytes))
  Sometimes turn on fast - read - char / fast - read - byte .   Switch on
        (when (and buffer-p
                   (not bivalent-stream-p)
                   (not output-p))
          (cond (character-stream-p
                 (setf (ansi-stream-cin-buffer fd-stream)
                       (make-array +ansi-stream-in-buffer-length+
                                   :element-type 'character)))
                ((equal target-type '(unsigned-byte 8))
                 (setf (ansi-stream-in-buffer fd-stream)
                       (make-array +ansi-stream-in-buffer-length+
                                   :element-type '(unsigned-byte 8))))))))

    (when output-p
      (when (or (not character-stream-p) bivalent-stream-p)
        (setf (values bout-routine bout-type bout-size output-bytes
                      char-size normalized-external-format)
              (let ((buffering (fd-stream-buffering fd-stream)))
                (if bivalent-stream-p
                    (pick-output-routine '(unsigned-byte 8)
                                         (if (eq :line buffering)
                                             :full
                                             buffering)
                                         external-format)
                    (pick-output-routine target-type buffering external-format))))
        (unless bout-routine
          (error "could not find any output routine for ~S buffered ~S"
                 (fd-stream-buffering fd-stream)
                 target-type)))
      (when character-stream-p
        (setf (values cout-routine cout-type cout-size output-bytes
                      char-size normalized-external-format)
              (pick-output-routine target-type
                                   (fd-stream-buffering fd-stream)
                                   external-format))
        (unless cout-routine
          (error "could not find any output routine for ~S buffered ~S"
                 (fd-stream-buffering fd-stream)
                 target-type)))
      (when normalized-external-format
        (setf (fd-stream-external-format fd-stream) normalized-external-format
              (fd-stream-char-size fd-stream) char-size))
      (when character-stream-p
        (setf (fd-stream-output-bytes fd-stream) output-bytes))
      (setf (fd-stream-out fd-stream) cout-routine
            (fd-stream-bout fd-stream) bout-routine
            (fd-stream-sout fd-stream) (if (eql cout-size 1)
                                           #'fd-sout #'ill-out))
      (setf output-size (or cout-size bout-size))
      (setf output-type (or cout-type bout-type)))

    (when (and input-size output-size
               (not (eq input-size output-size)))
      (error "Element sizes for input (~S:~S) and output (~S:~S) differ?"
             input-type input-size
             output-type output-size))
    (setf (fd-stream-element-size fd-stream)
          (or input-size output-size))

    (setf (fd-stream-element-type fd-stream)
          (cond ((equal input-type output-type)
                 input-type)
                ((null output-type)
                 input-type)
                ((null input-type)
                 output-type)
                ((subtypep input-type output-type)
                 input-type)
                ((subtypep output-type input-type)
                 output-type)
                (t
                 (error "Input type (~S) and output type (~S) are unrelated?"
                        input-type
                        output-type))))))

(defun release-fd-stream-resources (fd-stream)
  (handler-case
      (without-interrupts
  Drop handlers first .
        (when (fd-stream-handler fd-stream)
          (remove-fd-handler (fd-stream-handler fd-stream))
          (setf (fd-stream-handler fd-stream) nil))
  FD that appears open .
        (sb!unix:unix-close (fd-stream-fd fd-stream))
        (set-closed-flame fd-stream)
        (when (fboundp 'cancel-finalization)
          (cancel-finalization fd-stream)))
    (serious-condition (e)
      (error e)))
  (release-fd-stream-buffers fd-stream))

(defun flush-input-buffer (stream)
  (let ((unread (length (fd-stream-instead stream))))
    (setf (fill-pointer (fd-stream-instead stream)) 0)
    (let ((ibuf (fd-stream-ibuf stream)))
      (if ibuf
          (let ((head (buffer-head ibuf))
                (tail (buffer-tail ibuf)))
            (values (reset-buffer ibuf) (- (+ unread tail) head)))
          (values nil unread)))))

(defun fd-stream-clear-input (stream)
  (flush-input-buffer stream)
  #!+win32
  (progn
    (sb!win32:fd-clear-input (fd-stream-fd stream))
    (setf (fd-stream-listen stream) nil))
  #!-win32
  (catch 'eof-input-catcher
    (loop until (sysread-may-block-p stream)
          do
          (refill-input-buffer stream)
          (reset-buffer (fd-stream-ibuf stream)))
    t))

  Handle miscellaneous operations on FD - STREAM .
(defun fd-stream-misc-routine (fd-stream operation &optional arg1 arg2)
  (declare (ignore arg2))
  (case operation
    (:listen
     (labels ((do-listen ()
                (let ((ibuf (fd-stream-ibuf fd-stream)))
                  (or (not (eql (buffer-head ibuf) (buffer-tail ibuf)))
                      (fd-stream-listen fd-stream)
                      #!+win32
                      (sb!win32:fd-listen (fd-stream-fd fd-stream))
                      #!-win32
  If the read can block , LISTEN will certainly return NIL .
                      (if (sysread-may-block-p fd-stream)
                          nil
  Otherwise select(2 ) and CL : LISTEN have slightly
  different semantics .   The former returns that an FD
  That includes EOF .   However , LISTEN must return NIL
  at EOF .
                          (progn (catch 'eof-input-catcher
                                   (refill-input-buffer fd-stream))
  At this point either IBUF - HEAD ! = IBUF - TAIL
  and FD - STREAM - LISTEN is NIL , in which case
  we should return T , or IBUF - HEAD = =
  IBUF - TAIL and FD - STREAM - LISTEN is : EOF , in
                                 (do-listen)))))))
       (do-listen)))
    (:unread
     (decf (buffer-head (fd-stream-ibuf fd-stream))
           (fd-stream-character-size fd-stream arg1)))
    (:close
     (setf (ansi-stream-in-index fd-stream) +ansi-stream-in-buffer-length+
           (ansi-stream-cin-buffer fd-stream) nil
           (ansi-stream-in-buffer fd-stream) nil)
     (cond (arg1
            (let ((outputp (fd-stream-obuf fd-stream))
                  (file (fd-stream-file fd-stream))
                  (orig (fd-stream-original fd-stream)))
              (release-fd-stream-resources fd-stream)
              (when (and outputp file)
                (if orig
  If the original is EQ to file we are appending to
                    (unless (eq orig file)
                      (multiple-value-bind (okay err)
                          (sb!unix:unix-rename orig file)
                        (unless okay
                          (error 'simple-stream-error
                                 :format-control
                                 "~@<Couldn't restore ~S to its original contents ~
                                  from ~S while closing ~S: ~2I~_~A~:>"
                                 :format-arguments
                                 (list file orig fd-stream (strerror err))
                                 :stream fd-stream))))
                    (multiple-value-bind (okay err)
                        (sb!unix:unix-unlink file)
                      (unless okay
                        (error 'simple-file-error
                               :pathname file
                               :format-control
                               "~@<Couldn't remove ~S while closing ~S: ~2I~_~A~:>"
                               :format-arguments
                               (list file fd-stream (strerror err)))))))))
           (t
            (finish-fd-stream-output fd-stream)
            (let ((orig (fd-stream-original fd-stream)))
              (when (and orig (fd-stream-delete-original fd-stream))
                (multiple-value-bind (okay err) (sb!unix:unix-unlink orig)
                  (unless okay
                    (error 'simple-file-error
                           :pathname orig
                           :format-control
                           "~@<couldn't delete ~S while closing ~S: ~2I~_~A~:>"
                           :format-arguments
                           (list orig fd-stream (strerror err)))))))
  original can be done first .
            (release-fd-stream-resources fd-stream))))
    (:clear-input
     (fd-stream-clear-input fd-stream))
    (:force-output
     (flush-output-buffer fd-stream))
    (:finish-output
     (finish-fd-stream-output fd-stream))
    (:element-type
     (fd-stream-element-type fd-stream))
    (:external-format
     (fd-stream-external-format fd-stream))
    (:interactive-p
     (plusp (the (integer 0)
              (sb!unix:unix-isatty (fd-stream-fd fd-stream)))))
    (:line-length
     80)
    (:charpos
     (fd-stream-char-pos fd-stream))
    (:file-length
     (unless (fd-stream-file fd-stream)
  This is a TYPE - ERROR because ANSI 's species FILE - LENGTH
       (error 'simple-type-error
              :datum fd-stream
              :expected-type 'fd-stream
              :format-control "~S is not a stream associated with a file."
              :format-arguments (list fd-stream)))
     #!-win32
     (multiple-value-bind (okay dev ino mode nlink uid gid rdev size
                                atime mtime ctime blksize blocks)
         (sb!unix:unix-fstat (fd-stream-fd fd-stream))
       (declare (ignore ino nlink uid gid rdev
                        atime mtime ctime blksize blocks))
       (unless okay
         (simple-stream-perror "failed Unix fstat(2) on ~S" fd-stream dev))
       (if (zerop mode)
           nil
           (truncate size (fd-stream-element-size fd-stream))))
     #!+win32
     (let* ((handle (fd-stream-fd fd-stream))
            (element-size (fd-stream-element-size fd-stream)))
       (multiple-value-bind (got native-size)
           (sb!win32:get-file-size-ex handle 0)
         (if (zerop got)
             (let* ((here (sb!unix:unix-lseek handle 0 sb!unix:l_incr))
                    (there (sb!unix:unix-lseek handle 0 sb!unix:l_xtnd)))
               (when (and here there)
                 (sb!unix:unix-lseek handle here sb!unix:l_set)
                 (truncate there element-size)))
             (truncate native-size element-size)))))
    (:file-string-length
     (etypecase arg1
       (character (fd-stream-character-size fd-stream arg1))
       (string (fd-stream-string-size fd-stream arg1))))
    (:file-position
     (if arg1
         (fd-stream-set-file-position fd-stream arg1)
         (fd-stream-get-file-position fd-stream)))))

                              : seconds timeout ) ) ) ) )

(defun finish-fd-stream-output (stream)
  (flush-output-buffer stream)
  (do ()
      ((null (fd-stream-output-queue stream)))
    (aver (fd-stream-serve-events stream))
    (serve-all-events)))

(defun fd-stream-get-file-position (stream)
  (declare (fd-stream stream))
  (without-interrupts
    (let ((posn (sb!unix:unix-lseek (fd-stream-fd stream) 0 sb!unix:l_incr)))
      (declare (type (or (alien sb!unix:unix-offset) null) posn))
      (when (integerp posn)
  than reported by lseek ( ) because lseek ( ) obviously
        (dolist (buffer (fd-stream-output-queue stream))
          (incf posn (- (buffer-tail buffer) (buffer-head buffer))))
        (let ((obuf (fd-stream-obuf stream)))
          (when obuf
            (incf posn (buffer-tail obuf))))
  read from UNIX but not supplied to the user of the
        (let ((ibuf (fd-stream-ibuf stream)))
          (when ibuf
            (decf posn (- (buffer-tail ibuf) (buffer-head ibuf)))))
        (truncate posn (fd-stream-element-size stream))))))

(defun fd-stream-set-file-position (stream position-spec)
  (declare (fd-stream stream))
  (check-type position-spec
              (or (alien sb!unix:unix-offset) (member nil :start :end))
              "valid file position designator")
  (tagbody
   :again
     (finish-fd-stream-output stream)
     (without-interrupts
       (unless (fd-stream-output-finished-p stream)
         (go :again))
       (flush-input-buffer stream)
       (setf (fd-stream-listen stream) nil)
         (multiple-value-bind (offset origin)
             (case position-spec
               (:start
                (values 0 sb!unix:l_set))
               (:end
                (values 0 sb!unix:l_xtnd))
               (t
                (values (* position-spec (fd-stream-element-size stream))
                        sb!unix:l_set)))
           (declare (type (alien sb!unix:unix-offset) offset))
           (let ((posn (sb!unix:unix-lseek (fd-stream-fd stream)
                                           offset origin)))
  dealt with above . In times past we used to return NIL for
             (return-from fd-stream-set-file-position
               (typep posn '(alien sb!unix:unix-offset))))))))



  If INPUT is non - NIL , allow input operations . If OUTPUT is non - nil ,
  allow output operations . If neither INPUT nor OUTPUT is specified ,
  TIMEOUT ( if true ) is the number of seconds to wait for input . If
  NIL ( the default ) , then wait forever . When we time out , we signal
  handle blocking IO on the stream .
(defun make-fd-stream (fd
                       &key
                       (input nil input-p)
                       (output nil output-p)
                       (element-type 'base-char)
                       (buffering :full)
                       (external-format :default)
                       serve-events
                       timeout
                       file
                       original
                       delete-original
                       pathname
                       input-buffer-p
                       dual-channel-p
                       (name (if file
                                 (format nil "file ~A" file)
                                 (format nil "descriptor ~W" fd)))
                       auto-close)
  (declare (type index fd) (type (or real null) timeout)
           (type (member :none :line :full) buffering))
  (cond ((not (or input-p output-p))
         (setf input t))
        ((not (or input output))
         (error "File descriptor must be opened either for input or output.")))
  (let ((stream (%make-fd-stream :fd fd
                                 :fd-type (progn
                                            #!-win32 (sb!unix:fd-type fd)
                                            #!+win32 (if serve-events
                                                         :unknown
                                                         :regular))
                                 :name name
                                 :file file
                                 :original original
                                 :delete-original delete-original
                                 :pathname pathname
                                 :buffering buffering
                                 :dual-channel-p dual-channel-p
                                 :bivalent-p (eq element-type :default)
                                 :serve-events serve-events
                                 :timeout
                                 (if timeout
                                     (coerce timeout 'single-float)
                                     nil))))
    (set-fd-stream-routines stream element-type external-format
                            input output input-buffer-p)
    (when (and auto-close (fboundp 'finalize))
      (finalize stream
                (lambda ()
                  (sb!unix:unix-close fd)
                  #!+sb-show
                  (format *terminal-io* "** closed file descriptor ~W **~%"
                          fd))
                :dont-save t))
    stream))

(defun pick-backup-name (name)
  (declare (type simple-string name))
  (concatenate 'simple-string name ".bak"))

(defun ensure-one-of (item list what)
  (unless (member item list)
    (error 'simple-type-error
           :datum item
           :expected-type `(member ,@list)
           :format-control "~@<~S is ~_invalid for ~S; ~_need one of~{ ~S~}~:>"
           :format-arguments (list item what list))))

  Rename NAMESTRING to ORIGINAL . First , check whether we have write
(defun rename-the-old-one (namestring original)
  (unless (sb!unix:unix-access namestring sb!unix:w_ok)
    (error "~@<The file ~2I~_~S ~I~_is not writable.~:>" namestring))
  (multiple-value-bind (okay err) (sb!unix:unix-rename namestring original)
    (if okay
        t
        (error 'simple-file-error
               :pathname namestring
               :format-control
               "~@<couldn't rename ~2I~_~S ~I~_to ~2I~_~S: ~4I~_~A~:>"
               :format-arguments (list namestring original (strerror err))))))

(defun open (filename
             &key
             (direction :input)
             (element-type 'base-char)
             (if-exists nil if-exists-given)
             (if-does-not-exist nil if-does-not-exist-given)
             (external-format :default)
  Squelch assignment warning .
             (direction direction)
             (if-does-not-exist if-does-not-exist)
             (if-exists if-exists))
  #!+sb-doc
  "Return a stream which reads from or writes to FILENAME.
  Defined keywords:
   :DIRECTION - one of :INPUT, :OUTPUT, :IO, or :PROBE
   :ELEMENT-TYPE - the type of object to read or write, default BASE-CHAR
   :IF-EXISTS - one of :ERROR, :NEW-VERSION, :RENAME, :RENAME-AND-DELETE,
                       :OVERWRITE, :APPEND, :SUPERSEDE or NIL
   :IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or NIL
  See the manual for details."

  (multiple-value-bind (input output mask)
      (ecase direction
        (:input  (values   t nil sb!unix:o_rdonly))
        (:output (values nil   t sb!unix:o_wronly))
        (:io     (values   t   t sb!unix:o_rdwr))
        (:probe  (values   t nil sb!unix:o_rdonly)))
    (declare (type index mask))
           (pathname (merge-pathnames filename))
           (physical (physicalize-pathname pathname))
           (truename (probe-file physical))
           (namestring (cond (truename
                              (native-namestring truename :as-file t))
                             ((or (not input)
                                  (and input (eq if-does-not-exist :create))
                                  (and (eq direction :io) (not if-does-not-exist-given)))
                              (native-namestring physical :as-file t)))))
      (cond (output
             (unless if-exists-given
               (setf if-exists
                     (if (eq (pathname-version pathname) :newest)
                         :new-version
                         :error)))
             (ensure-one-of if-exists
                            '(:error :new-version :rename
                                     :rename-and-delete :overwrite
                                     :append :supersede nil)
                            :if-exists)
             (case if-exists
               ((:new-version :error nil)
                (setf mask (logior mask sb!unix:o_excl)))
               ((:rename :rename-and-delete)
                (setf mask (logior mask sb!unix:o_creat)))
               ((:supersede)
                (setf mask (logior mask sb!unix:o_trunc)))
               (:append
                (setf mask (logior mask sb!unix:o_append)))))
            (t
             (setf if-exists :ignore-this-arg)))

      (unless if-does-not-exist-given
        (setf if-does-not-exist
              (cond ((eq direction :input) :error)
                    ((and output
                          (member if-exists '(:overwrite :append)))
                     :error)
                    ((eq direction :probe)
                     nil)
                    (t
                     :create))))
      (ensure-one-of if-does-not-exist
                     '(:error :create nil)
                     :if-does-not-exist)
      (if (eq if-does-not-exist :create)
        (setf mask (logior mask sb!unix:o_creat)))

      (let ((original (case if-exists
                        ((:rename :rename-and-delete)
                         (pick-backup-name namestring))
                        ((:append :overwrite)
   : Provent CLOSE from deleting
                         namestring)))
            (delete-original (eq if-exists :rename-and-delete))
            (mode #o666))
        (when (and original (not (eq original namestring)))
          (let ((exists
                 (and namestring
                      (multiple-value-bind (okay err/dev inode orig-mode)
                          (sb!unix:unix-stat namestring)
                        (declare (ignore inode)
                                 (type (or index null) orig-mode))
                        (cond
                         (okay
                          (when (and output (= (logand orig-mode #o170000)
                                               #o40000))
                            (error 'simple-file-error
                                   :pathname pathname
                                   :format-control
                                   "can't open ~S for output: is a directory"
                                   :format-arguments (list namestring)))
                          (setf mode (logand orig-mode #o777))
                          t)
                         ((eql err/dev sb!unix:enoent)
                          nil)
                         (t
                          (simple-file-perror "can't find ~S"
                                              namestring
                                              err/dev)))))))
            (unless (and exists
                         (rename-the-old-one namestring original))
              (setf original nil)
              (setf delete-original nil)
  In order to use : SUPERSEDE instead , we have to make
  sure  :  corresponds to
  IF - DOES - NOT - EXIST .  :  was set before
              (unless (eq if-does-not-exist :create)
                (setf mask
                      (logior (logandc2 mask sb!unix:o_creat)
                              sb!unix:o_trunc)))
              (setf if-exists :supersede))))

        (multiple-value-bind (fd errno)
            (if namestring
                (sb!unix:unix-open namestring mask mode)
                (values nil sb!unix:enoent))
          (labels ((open-error (format-control &rest format-arguments)
                     (error 'simple-file-error
                            :pathname pathname
                            :format-control format-control
                            :format-arguments format-arguments))
                   (vanilla-open-error ()
                     (simple-file-perror "error opening ~S" pathname errno)))
            (cond ((numberp fd)
                   (case direction
                     ((:input :output :io)
  For O_APPEND opened files , lseek returns 0 until first write .
                      (when (eq if-exists :append)
                        (sb!unix:unix-lseek fd 0 sb!unix:l_xtnd))
                      (make-fd-stream fd
                                      :input input
                                      :output output
                                      :element-type element-type
                                      :external-format external-format
                                      :file namestring
                                      :original original
                                      :delete-original delete-original
                                      :pathname pathname
                                      :dual-channel-p nil
                                      :serve-events nil
                                      :input-buffer-p t
                                      :auto-close t))
                     (:probe
                      (let ((stream
                             (%make-fd-stream :name namestring
                                              :fd fd
                                              :pathname pathname
                                              :element-type element-type)))
                        (close stream)
                        stream))))
                  ((eql errno sb!unix:enoent)
                   (case if-does-not-exist
                     (:error (vanilla-open-error))
                     (:create
                      (open-error "~@<The path ~2I~_~S ~I~_does not exist.~:>"
                                  pathname))
                     (t nil)))
                  ((and (eql errno sb!unix:eexist) (null if-exists))
                   nil)
                  (t
                   (vanilla-open-error)))))))))


(defvar *tty*)

(defvar *stdin*)

  the stream connected to the standard output ( file descriptor 1 )
(defvar *stdout*)

  the stream connected to the standard error output ( file descriptor 2 )
(defvar *stderr*)

  This is called when the cold load is first started up , and may also
(defun stream-cold-init-or-reset ()
  (stream-reinit)
  (setf *terminal-io* (make-synonym-stream '*tty*))
  (setf *standard-output* (make-synonym-stream '*stdout*))
  (setf *standard-input* (make-synonym-stream '*stdin*))
  (setf *error-output* (make-synonym-stream '*stderr*))
  (setf *query-io* (make-synonym-stream '*terminal-io*))
  (setf *debug-io* *query-io*)
  (setf *trace-output* *standard-output*)
  (values))

(defun stream-deinit ()
  (with-available-buffers-lock ()
    (without-package-locks
        (makunbound '*available-buffers*))))

(defun stdstream-external-format (fd outputp)
  #!-win32 (declare (ignore fd outputp))
  (let* ((keyword #!+win32 (if (and (/= fd -1)
                                    (logbitp 0 fd)
                                    (logbitp 1 fd))
                               :ucs-2
                               (if outputp
                                   (sb!win32::console-output-codepage)
                                   (sb!win32::console-input-codepage)))
                  #!-win32 (default-external-format))
         (ef (get-external-format keyword))
         (replacement (ef-default-replacement-character ef)))
    `(,keyword :replacement ,replacement)))

(defun stream-reinit (&optional init-buffers-p)
  (when init-buffers-p
    (with-available-buffers-lock ()
      (aver (not (boundp '*available-buffers*)))
      (setf *available-buffers* nil)))
  (with-output-to-string (*error-output*)
    (multiple-value-bind (in out err)
        #!-win32 (values 0 1 2)
        #!+win32 (sb!win32::get-std-handles)
      (flet ((stdio-stream (handle name inputp outputp)
               (make-fd-stream
                handle
                :name name
                :input inputp
                :output outputp
                :buffering :line
                :element-type :default
                :serve-events inputp
                :external-format (stdstream-external-format handle outputp))))
        (setf *stdin*  (stdio-stream in  "standard input"    t nil))
        (setf *stdout* (stdio-stream out "standard output" nil   t))
        (setf *stderr* (stdio-stream err "standard error"  nil   t))))
    #!+win32
    (setf *tty* (make-two-way-stream *stdin* *stdout*))
    #!-win32
    (let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string))
           (tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666)))
      (if tty
          (setf *tty*
                (make-fd-stream tty :name "the terminal"
                                :input t :output t :buffering :line
                                :external-format (stdstream-external-format
                                                  tty t)
                                :serve-events (or #!-win32 t)
                                :auto-close t))
          (setf *tty* (make-two-way-stream *stdin* *stdout*))))
    (princ (get-output-stream-string *error-output*) *stderr*))
  (values))


(defun beep (stream)
  (write-char (code-char bell-char-code) stream)
  (finish-output stream))

(defun file-name (stream &optional new-name)
  (when (typep stream 'fd-stream)
      (cond (new-name
             (setf (fd-stream-pathname stream) new-name)
             (setf (fd-stream-file stream)
                   (native-namestring (physicalize-pathname new-name)
                                      :as-file t))
             t)
            (t
             (fd-stream-pathname stream)))))
