win32-fh work, mostly RUN-PROGRAM-related. Solid on Unix, not on Win32

[sbcl/kreuter.git] / src / code / fd-stream.lisp

;;;; 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-spinlock* (sb!thread::make-spinlock
                                      :name "lock for *AVAILABLE-BUFFERS*")
  #!+sb-doc
  "Mutex for access to *AVAILABLE-BUFFERS*.")

(defmacro with-available-buffers-lock ((&optional) &body body)
  ;; CALL-WITH-SYSTEM-SPINLOCK because
  ;;
  ;; 1. 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
  ;;
  ;; 2. this can potentially be a fairly busy (but also probably
  ;;    uncontended) lock, so we don't want to pay the syscall per
  ;;    release -- hence a spinlock.
  ;;
  ;; ...again, once we have smarted locks the spinlock here can become
  ;; a mutex.
  `(sb!thread::call-with-system-spinlock (lambda () ,@body)
                                         *available-buffers-spinlock*))

(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*))))))
\f
;;;; 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 (should be deprecated: this slot's
  ;; purpose is better served with PRINT-OBJECT methods).
  (name nil)
  ;; the file this stream is for (Deprecated: we now store the
  ;; truename, rather than a string, in the TRUENAME slot.  Nothing in
  ;; SBCL should use this slot anymore; if you're looking at this
  ;; because we broke your use of FD-STREAMs, you're probably doing
  ;; something fishy.)
  (file nil :type null :read-only t)

  ;; Deprecated.  We don't use these anymore, and you shouldn't either.
  (original nil :type null :read-only t)
  (delete-original nil :type null :read-only t)
  ;;; 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 fixnum)
  ;; 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))

  ;; the input buffer
  (unread nil)
  (ibuf nil :type (or buffer null))

  ;; 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))

  ;; Defaulted pathname used to open this stream (returned by PATHNAME)
  (pathname nil :type (or pathname null))
  (external-format :default)
  (output-bytes #'ill-out :type function)
  ;; Pathname of the file actually associated with the stream (used by
  ;; TRUENAME).
  (truename nil :type (or pathname null))
  ;; If it's built with :OPEN-LAZY-FILE-DISPOSITION, for openings that
  ;; create fresh files, the altname is the truename the file will
  ;; have after a non-aborting CLOSE; if it's built without
  ;; :OPEN-LAZY-FILE-DISPOSITION, the altname is the intermediate name of
  ;; the old file for openings that replace an existing file.
  (altname nil :type (or pathname null))
  ;; Actions to take after closing the descriptor (mostly side effects
  ;; on the file system).  If it's NIL, no actions will be taken.
  (after-close nil :type (or function null))
  #!+unix
  (owner-pid (sb!unix:unix-getpid) :type (or null integer))
;  #!+win32-uses-file-handles
  ;; Win32 socket handles need some extra metadata for event
  ;; discrimination.
;  (events nil :type (or nil fixnum))
  )

(def!method print-object ((fd-stream fd-stream) stream)
  (declare (type stream stream))
  (print-unreadable-object (fd-stream stream :type t :identity t)
    (cond ((fd-stream-truename fd-stream)
           (format stream "for file ~A" (fd-stream-truename fd-stream)))
          ((fd-stream-name fd-stream)
           (format stream "for ~S" (fd-stream-name fd-stream)))
          (t
           (format stream "for descriptor ~D" (fd-stream-fd fd-stream))))
    (format stream "~:[ (stream is closed)~;~]"
            (open-stream-p fd-stream))))
\f
;;;; OS file device wrapper functions.  For now, only use the win32
;;;; API in case :WIN32-USES-FILE-HANDLES is in the target features.
;;;; These functions are meant to have the API that the SB-UNIX
;;;; bindings do: returning a true value for success, NIL and an error
;;;; code for failure.  The success value might be meaningful, or
;;;; might not (e.g., for OS-CLOSE).  The error codes are
;;;; platform-specific; the error signaling machinery
;;;; (SIMPLE-STREAM-PERROR, SIMPLE-FILE-PERROR) are responsible for
;;;; turning these codes into messages or types.

(defun os-read (device buffer length)
  #!-win32-uses-file-handles
  (sb!unix:unix-read device buffer length)
  #!+win32-uses-file-handles
  (sb!win32:read-file device buffer length))

(defun os-write (device buffer offset count)
  #!-win32-uses-file-handles
  (sb!unix:unix-write device buffer offset count)
  #!+win32-uses-file-handles
  (sb!win32:write-file device buffer offset count))

(defun os-close (device)
  #!-win32-uses-file-handles
  (sb!unix:unix-close device)
  #!+win32-uses-file-handles
  (sb!win32:close-handle device))

(defun os-seek (device position whence)
  "Reposition the file pointer for DEVICE using POSITION and
   WHENCE.  WHENCE must be one of :START, :END, or T (meaning
   relative to the current position)."
  #!-win32-uses-file-handles
  (sb!unix:unix-lseek device position
                      (ecase whence
                        (:start sb!unix:l_set)
                        (t sb!unix:l_incr)
                        (:end sb!unix:l_xtnd)))
  #!+win32-uses-file-handles
  (sb!win32:set-file-pointer
   device (ldb (byte 32 0) position) (ldb (byte 32 32) position)
   (ecase whence
     (:start sb!win32:file_begin)
     (t sb!win32:file_current)
     (:end sb!win32:file_end))))

(defun os-file-length (device)
  #!-win32-uses-file-handles
  ;; FIXME: the wrapped_stat structure should really die.  In this
  ;; case, replacing it with a function that took an fd and returned
  ;; the size would suffice.
  (nth-value 8 (sb!unix:unix-fstat device))
  #!+win32-uses-file-handles
  (sb!win32:get-file-size device))

;;; In order to not go bonkers trying to make POSIX open(2) and Win32
;;; CreateFile() look similar, we invent the following internal API:
;;; we'll use a lightweight structure, OS-OPEN-ARGUMENTS, containing
;;; everything to be passed to open() or CreateFile() other than the
;;; filename.  The constructor, MAKE-OS-OPEN-ARGUMENTS, takes keywords
;;; and &ALLOW-OTHER-KEYS, so that we can call the constructor on
;;; whatever arguments OPEN receives; and there's a merging operation
;;; that produces a new OS-OPEN-ARGUMENTS structure using
;;; component-wise replacement rules like a CLtL1ish MERGE-PATHNAMES.
;;; (So to make the following idea work, NIL must /never/ be a
;;; meaningful argument to an opening syscall.)  For the most part,
;;; this means that most of the code can pass an opaque thing down the
;;; call chain.

;; FIXME, maybe: I tried having this be a MACROLET, but the compiler
;; complained that the lexical environment was too hairy to define the
;; DEFSTRUCT accessors inside the MACROLET.  Shrug.
(defmacro define-unnamed-list-struct (name (&rest slot-names))
  (let ((strict-constructor (read-from-string (format nil "%MAKE-~A" name)))
        (loose-constructor (read-from-string (format nil "MAKE-~A" name))))
    `(progn (defstruct (,name (:type list) (:constructor ,strict-constructor))
              ,@slot-names)
           (defun ,loose-constructor
               (&key ,@slot-names &allow-other-keys)
             (list ,@slot-names)))))

(define-unnamed-list-struct os-open-arguments
    #!-win32-uses-file-handles
    (flags mode)
    #!+win32-uses-file-handles
    (desired-access share-mode security-attributes creation-disposition
    flags-and-attributes template-file))


;; Unlike *DEFAULT-PATHNAME-DEFAULTS*, this should not be rebound
;; anyplace.  Explanations of these defaults: on both Unix and
;; Windows, the defaults will open a file for reading only, and won't
;; create a file where one doesn't exist.  The other defaults have to
;; do with metadata on a newly created file: on Unix, we are maximally
;; permissive (but remember the umask); on Windows, everything gets
;; defaulted in the file system.
(defvar *default-os-open-arguments-defaults*
    #!-win32-uses-file-handles
    (%make-os-open-arguments :flags sb!unix:o_rdonly :mode #o666)
    #!+win32-uses-file-handles
    (%make-os-open-arguments :desired-access sb!win32:generic_read
                            :share-mode 0
                            :security-attributes 0
                            :creation-disposition sb!win32:open_existing
                            :flags-and-attributes 0
                            :template-file 0)
  "Default arguments to the operating system's file opening operation.")

(defun merge-os-open-arguments
    (args &optional (defaults *default-os-open-arguments-defaults*))
  (assert (= (length args) (length *default-os-open-arguments-defaults*)))
  (mapcar (lambda (x y) (or x y)) args defaults))

(defun os-open (filename os-open-arguments)
  (let ((args (merge-os-open-arguments os-open-arguments)))
    #!-win32-uses-file-handles
    (destructuring-bind (flags mode) args
      (sb!unix:unix-open filename flags mode))
    #!+win32-uses-file-handles
    (destructuring-bind
          (access sharemode attributes disposition flags template) args
      (sb!win32:create-file
       filename access sharemode attributes disposition flags template))))
\f
;;;; 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, queue whatever is left over.
               (aver (< head tail))
               (synchronize-stream-output stream)
               (let ((length (- tail head)))
                 (multiple-value-bind (count errno)
                     (os-write (fd-stream-fd stream) (buffer-sap obuf)
                               head length)
                   (cond ((eql count length)
                          ;; Complete write -- we can use the same buffer.
                          (reset-buffer obuf))
                         (count
                          ;; Partial write -- update buffer status and queue.
                          ;; Do not use INCF! Another thread might have moved
                          ;; head...
                          (setf (buffer-head obuf) (+ count head))
                          (%queue-and-replace-output-buffer stream))
                         #!-win32
                         ((eql errno sb!unix:ewouldblock)
                          ;; Blocking, queue.
                          (%queue-and-replace-output-buffer stream))
                         (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)
  (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)
  (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)
             (os-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. Requeue.
                  (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)
               (os-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.
(defun output-raw-bytes (stream thing &optional start end)
  (write-or-buffer-output stream thing (or start 0) (or end (length thing))))

(define-compiler-macro output-raw-bytes (stream thing &optional start end)
  (deprecation-warning 'output-raw-bytes)
  (let ((x (gensym "THING")))
    `(let ((,x ,thing))
       (write-or-buffer-output ,stream ,x (or ,start 0) (or ,end (length ,x))))))
\f
;;;; 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)
               #!+unix (strerror errno)
               #!+win32 (sb!win32:get-last-error-message errno))))

(defun file-error-type (error-code)
  (case error-code
    (#!+unix #.sb!unix:enoent #!+win32 #.sb!win32:error_file_not_found
             'file-does-not-exist)
    (#!+unix #.sb!unix:eexist
     ;; What's the difference between ERROR_FILE_EXISTS and
     ;; ERROR_ALREADY_EXISTS?  AFAICT, one hundred and three.
     #!+win32 #.sb!win32:error_file_exists
     #!+win32 #.sb!win32:error_already_exists
     'file-exists)
    (otherwise 'simple-file-error)))

(defun simple-file-perror (note-format pathname errno)
  (error (file-error-type errno)
         :pathname pathname
         :format-control "~@<~?: ~2I~_~A~:>"
         :format-arguments
         (list note-format (list pathname)
               #!+unix (strerror errno)
               #!+win32 (sb!win32:get-last-error-message errno))))

(defun stream-decoding-error (stream octets)
  (error 'stream-decoding-error
         :stream stream
         ;; FIXME: dunno how to get at OCTETS currently, or even if
         ;; that's the right thing to report.
         :octets octets))
(defun stream-encoding-error (stream code)
  (error 'stream-encoding-error
         :stream stream
         :code code))

(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 octets)
  (error 'c-string-decoding-error
         :external-format external-format
         :octets octets))

;;; 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
      (stream-decoding-error stream
                             (let* ((buffer (fd-stream-ibuf stream))
                                    (sap (buffer-sap buffer))
                                    (head (buffer-head buffer)))
                               (loop for i from 0 below octet-count
                                     collect (sap-ref-8 sap (+ head i)))))
    (attempt-resync ()
      :report (lambda (stream)
                (format stream
                        "~@<Attempt to resync the stream at a character ~
                        character boundary and continue.~@:>"))
      (fd-stream-resync stream)
      nil)
    (force-end-of-file ()
      :report (lambda (stream)
                (format stream "~@<Force an end of file.~@:>"))
      t)))

(defun stream-encoding-error-and-handle (stream code)
  (restart-case
      (stream-encoding-error stream code)
    (output-nothing ()
      :report (lambda (stream)
                (format stream "~@<Skip output of this character.~@:>"))
      (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 external-format-decoding-error (stream octet-count)
  (if (streamp stream)
      (stream-decoding-error stream octet-count)
      (c-string-decoding-error stream octet-count)))

(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)
        (os-seek (fd-stream-fd stream) (- adjust) t)))))

(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 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))))))

(defvar *external-formats* ()
  #!+sb-doc
  "List of all available external formats. Each element is a list of the
  element-type, string input function name, character input function name,
  and string output function name.")

(defun get-external-format (external-format)
  (dolist (entry *external-formats*)
    (when (member external-format (first entry))
      (return entry))))

(defun get-external-format-function (external-format index)
  (let ((entry (get-external-format external-format)))
    (when entry (nth index entry))))

;;; 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 external-format)))
      (when entry
        (return-from pick-output-routine
          (values (symbol-function (nth (ecase buffering
                                          (:none 4)
                                          (:line 5)
                                          (:full 6))
                                        entry))
                  'character
                  1
                  (symbol-function (fourth entry))
                  (first (first 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)))))
  ;; KLUDGE: dealing with the buffering here leads to excessive code
  ;; explosion.
  ;;
  ;; KLUDGE: also see comments in PICK-INPUT-ROUTINE
  (loop for i from 40 by 8 to 1024 ; ARB (KLUDGE)
        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))))
  (loop for i from 40 by 8 to 1024 ; ARB (KLUDGE)
        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)))))
\f
;;;; 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)
  #!+(and win32 (not win32-uses-file-handles))
  ;; This answers T at EOF on win32, I think.
  (not (sb!win32:fd-listen (fd-stream-fd stream)))
  #!+(and win32 win32-uses-file-handles)
  (not (sb!win32:handle-listen (fd-stream-fd stream)))
  #!-win32
  (sb!unix:with-restarted-syscall (count errno)
    (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set)))
      (sb!unix:fd-zero read-fds)
      (sb!unix:fd-set (fd-stream-fd stream) read-fds)
      (sb!unix:unix-fast-select (1+ (fd-stream-fd stream))
                                (sb!alien:addr read-fds)
                                nil nil 0 0))
    (case count
      ((1) nil)
      ((0) t)
      (otherwise
       (simple-stream-perror "couldn't check whether ~S is readable"
                             stream
                             errno)))))

;;; 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)
  (let ((fd (fd-stream-fd stream))
        (errno 0)
        (count 0))
    (declare (dynamic-extent fd errno count))
    (tagbody
       ;; Check for blocking input before touching the stream, as if
       ;; we happen to wait we are liable to be interrupted, and the
       ;; interrupt handler may use the same stream.
       (if (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))
         (signal-timeout 'io-timeout :stream stream :direction :read
                         :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 :wait-for-input))
            ((: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 os-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)
                      (os-read fd (sap+ sap tail) (- length tail)))
                (cond ((or (and (integerp count) (zerop count))
                           ;; Evidently, windows doesn't give you a
                           ;; zero-length read for a closed pipe, but
                           ;; an error.
                           #!+win32-uses-file-handles
                           (and (null count)
                                (eql errno sb!win32:error_broken_pipe)))
                       (setf (fd-stream-listen stream) :eof)
                       (/show0 "THROWing EOF-INPUT-CATCHER")
                       (throw 'eof-input-catcher nil))
                      ((null count)
                       #!+win32
                       (return :read-error)
                       #!-win32
                       (if (eql errno sb!unix:ewouldblock)
                           (return :wait-for-input)
                           (return :read-error)))
                      (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))
       (if (fd-stream-unread ,stream-var)
           (prog1
               (fd-stream-unread ,stream-var)
             (setf (fd-stream-unread ,stream-var) nil)
             (setf (fd-stream-listen ,stream-var) nil))
           (let ((,element-var nil)
                 (decode-break-reason nil))
             (do ((,retry-var t))
                 ((not ,retry-var))
               (unless
                   (catch 'eof-input-catcher
                     (setf decode-break-reason
                           (block decode-break-reason
                             (input-at-least ,stream-var 1)
                             (let* ((byte (sap-ref-8 (buffer-sap ibuf)
                                                     (buffer-head ibuf))))
                               (declare (ignorable byte))
                               (setq size ,bytes)
                               (input-at-least ,stream-var size)
                               (setq ,element-var (locally ,@read-forms))
                               (setq ,retry-var nil))
                             nil))
                     (when decode-break-reason
                       (stream-decoding-error-and-handle stream
                                                         decode-break-reason))
                     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 (fd-stream-unread ,stream-var)
           (prog1
               (fd-stream-unread ,stream-var)
             (setf (fd-stream-unread ,stream-var) nil)
             (setf (fd-stream-listen ,stream-var) nil))
           (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)
    (dolist (entry *external-formats*)
      (when (member external-format (first entry))
        (return-from pick-input-routine
          (values (symbol-function (third entry))
                  'character
                  1
                  (symbol-function (second entry))
                  (first (first 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
  (loop for i from 40 by 8 to 1024 ; ARB (well, KLUDGE 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))))
  (loop for i from 40 by 8 to 1024 ; ARB (well, KLUDGE 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))
  (let ((unread (fd-stream-unread stream)))
    (when unread
      ;; AVERs designed to fail when we have more complicated
      ;; character representations.
      (aver (typep unread 'base-char))
      (aver (= (fd-stream-element-size stream) 1))
      ;; KLUDGE: this is a slightly-unrolled-and-inlined version of
      ;; %BYTE-BLT
      (etypecase buffer
        (system-area-pointer
         (setf (sap-ref-8 buffer start) (char-code unread)))
        ((simple-unboxed-array (*))
         (setf (aref buffer start) unread)))
      (setf (fd-stream-unread stream) nil)
      (setf (fd-stream-listen stream) nil)
      (incf total-copied)))
  (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)
  (dolist (entry *external-formats*)
    (when (member (fd-stream-external-format stream) (first entry))
      (return-from fd-stream-resync
        (funcall (symbol-function (eighth entry)) stream)))))

(defun get-fd-stream-character-sizer (stream)
  (dolist (entry *external-formats*)
    (when (member (fd-stream-external-format stream) (first entry))
      (return-from get-fd-stream-character-sizer (ninth 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
    (find external-format *external-formats* :test #'member :key #'car)))

(defun variable-width-external-format-p (ef-entry)
  (when (eighth ef-entry) t))

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

;;; FIXME: OAOOM here vrt. *EXTERNAL-FORMAT-FUNCTIONS* in fd-stream.lisp
(defmacro define-external-format (external-format size output-restart
                                  out-expr in-expr)
  (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))
         (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 (ignore byte))
        ,size)
      (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)))
              (setf (buffer-tail obuf)
                    (string-dispatch (simple-base-string
                                      #!+sb-unicode
                                      (simple-array character (*))
                                      string)
                        string
                      (let ((sap (buffer-sap obuf))
                            (len (buffer-length obuf))
                            ;; FIXME: rename
                            (tail (buffer-tail obuf)))
                       (declare (type index tail)
                                ;; STRING bounds have already been checked.
                                (optimize (safety 0)))
                       (loop
                         (,@(if output-restart
                                `(catch 'output-nothing)
                                `(progn))
                            (do* ()
                                 ((or (= start end) (< (- len tail) 4)))
                              (let* ((byte (aref string start))
                                     (bits (char-code byte)))
                                ,out-expr
                                (incf tail ,size)
                                (incf start)))
                            ;; Exited from the loop normally
                            (return tail))
                         ;; Exited via CATCH. Skip the current character
                         ;; and try the inner loop again.
                         (incf start))))))
            (when (< start end)
              (flush-output-buffer stream)))
          (when flush-p
            (flush-output-buffer stream))))
      (def-output-routines (,format
                            ,size
                            ,output-restart
                            (:none character)
                            (:line character)
                            (:full character))
          (if (eql byte #\Newline)
              (setf (fd-stream-char-pos stream) 0)
              (incf (fd-stream-char-pos stream)))
          (let* ((obuf (fd-stream-obuf stream))
                 (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 (index start) (end (+ start requested)))
        (declare (type fd-stream stream)
                 (type index start requested index end)
                 (type
                  (simple-array character (#.+ansi-stream-in-buffer-length+))
                  buffer))
        (let ((unread (fd-stream-unread stream)))
          (when unread
            (setf (aref buffer index) unread)
            (setf (fd-stream-unread stream) nil)
            (setf (fd-stream-listen stream) nil)
            (incf index)))
        (do ()
            (nil)
          (let* ((ibuf (fd-stream-ibuf stream))
                 (head (buffer-head ibuf))
                 (tail (buffer-tail ibuf))
                 (sap (buffer-sap ibuf)))
            (declare (type index head tail)
                     (type system-area-pointer sap))
            ;; Copy data from stream buffer into user's buffer.
            (dotimes (i (min (truncate (- tail head) ,size)
                             (- end index)))
              (declare (optimize speed))
              (let* ((byte (sap-ref-8 sap head)))
                (setf (aref buffer index) ,in-expr)
                (incf index)
                (incf head ,size)))
            (setf (buffer-head ibuf) head)
            ;; Maybe we need to refill the stream buffer.
            (cond ( ;; If there was enough data in the stream buffer, we're done.
                   (= index end)
                   (return (- index start)))
                  ( ;; 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 (- index start))))
                  ;; Otherwise we refilled the stream buffer, so fall
                  ;; through into another pass of the loop.
                  ))))
      (def-input-routine ,in-char-function (character ,size sap head)
        (let ((byte (sap-ref-8 sap head)))
          ,in-expr))
      (defun ,read-c-string-function (sap element-type)
        (declare (type system-area-pointer sap)
                 (type (member character base-char) element-type))
        (locally
            (declare (optimize (speed 3) (safety 0)))
          (let* ((stream ,name)
                 (length
                  (loop for head of-type index upfrom 0 by ,size
                        for count of-type index upto (1- array-dimension-limit)
                        for byte = (sap-ref-8 sap head)
                        for char of-type character = ,in-expr
                        until (zerop (char-code char))
                        finally (return count)))
                 ;; Inline the common cases
                 (string (make-string length :element-type element-type)))
            (declare (ignorable stream)
                     (type index length)
                     (type simple-string string))
            (/show0 before-copy-loop)
            (loop for head of-type index upfrom 0 by ,size
               for index of-type index below length
               for byte = (sap-ref-8 sap head)
               for char of-type character = ,in-expr
               do (setf (aref string index) char))
            string))) ;; last loop rewrite to dotimes?
        (defun ,output-c-string-function (string)
          (declare (type simple-string string))
          (locally
              (declare (optimize (speed 3) (safety 0)))
            (let* ((length (length string))
                   (,n-buffer (make-array (* (1+ length) ,size)
                                          :element-type '(unsigned-byte 8)))
                   (tail 0)
                   (stream ,name))
              (declare (type index length tail))
              (with-pinned-objects (,n-buffer)
                (let ((sap (vector-sap ,n-buffer)))
                  (declare (system-area-pointer sap))
                  (dotimes (i length)
                    (let* ((byte (aref string i))
                           (bits (char-code byte)))
                      (declare (ignorable byte bits))
                      ,out-expr)
                    (incf tail ,size))
                  (let* ((bits 0)
                         (byte (code-char bits)))
                    (declare (ignorable bits byte))
                    ,out-expr)))
              ,n-buffer)))
      (setf *external-formats*
       (cons '(,external-format ,in-function ,in-char-function ,out-function
               ,@(mapcar #'(lambda (buffering)
                             (intern (format nil format (string buffering))))
                         '(:none :line :full))
               nil ; no resync-function
               ,size-function ,read-c-string-function ,output-c-string-function)
        *external-formats*)))))

(defmacro define-external-format/variable-width
    (external-format output-restart out-size-expr
     out-expr in-size-expr in-expr)
  (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 string start end))
          (do ()
              ((= end start))
            (let ((obuf (fd-stream-obuf stream)))
              (setf (buffer-tail obuf)
                    (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)))
                        (loop
                          (,@(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)
                                 (incf start)))
                             ;; Exited from the loop normally
                             (return tail))
                          ;; Exited via CATCH. Skip the current character
                          ;; and try the inner loop again.
                          (incf start))))))
            (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))
        (let ((unread (fd-stream-unread stream)))
          (when unread
            (setf (aref buffer start) unread)
            (setf (fd-stream-unread stream) nil)
            (setf (fd-stream-listen stream) nil)
            (incf 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
                      (let ((byte (sap-ref-8 sap head)))
                        (declare (ignorable byte))
                        (setq size ,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 Lisp 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)))
                (setf head (buffer-head ibuf))
                (setf tail (buffer-tail ibuf))))
            (setf (buffer-head ibuf) head)
            ;; Maybe we need to refill the stream buffer.
            (cond ( ;; If there were enough data in the stream buffer, we're done.
                   (= total-copied requested)
                   (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)))
          (loop
            (input-at-least stream 2)
            (incf (buffer-head ibuf))
            (unless (block decode-break-reason
                      (let* ((sap (buffer-sap ibuf))
                             (head (buffer-head ibuf))
                             (byte (sap-ref-8 sap head))
                             (size ,in-size-expr))
                        (declare (ignorable byte))
                        (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 ,in-size-expr
                                         char ,in-expr)
                                   (incf head size)
                                   nil))
                           (when decode-break-reason
                             (c-string-decoding-error ,name 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 ,in-size-expr
                            char ,in-expr)
                      (incf head size)
                      nil))
              (when decode-break-reason
                (c-string-decoding-error ,name 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)))

      (setf *external-formats*
       (cons '(,external-format ,in-function ,in-char-function ,out-function
               ,@(mapcar #'(lambda (buffering)
                             (intern (format nil format (string buffering))))
                         '(:none :line :full))
               ,resync-function
               ,size-function ,read-c-string-function ,output-c-string-function)
        *external-formats*)))))

;;; Multiple names for the :ISO{,-}8859-* families are needed because on
;;; FreeBSD (and maybe other BSD systems), nl_langinfo("LATIN-1") will
;;; return "ISO8859-1" instead of "ISO-8859-1".
(define-external-format (:latin-1 :latin1 :iso-8859-1 :iso8859-1)
    1 t
  (if (>= bits 256)
      (external-format-encoding-error stream bits)
      (setf (sap-ref-8 sap tail) bits))
  (code-char byte))

(define-external-format (:ascii :us-ascii :ansi_x3.4-1968
                         :iso-646 :iso-646-us :|646|)
    1 t
  (if (>= bits 128)
      (external-format-encoding-error stream bits)
      (setf (sap-ref-8 sap tail) bits))
  (code-char byte))

(let* ((table (let ((s (make-string 256)))
                (map-into s #'code-char
                          '(#x00 #x01 #x02 #x03 #x9c #x09 #x86 #x7f #x97 #x8d #x8e #x0b #x0c #x0d #x0e #x0f
                            #x10 #x11 #x12 #x13 #x9d #x85 #x08 #x87 #x18 #x19 #x92 #x8f #x1c #x1d #x1e #x1f
                            #x80 #x81 #x82 #x83 #x84 #x0a #x17 #x1b #x88 #x89 #x8a #x8b #x8c #x05 #x06 #x07
                            #x90 #x91 #x16 #x93 #x94 #x95 #x96 #x04 #x98 #x99 #x9a #x9b #x14 #x15 #x9e #x1a
                            #x20 #xa0 #xe2 #xe4 #xe0 #xe1 #xe3 #xe5 #xe7 #xf1 #xa2 #x2e #x3c #x28 #x2b #x7c
                            #x26 #xe9 #xea #xeb #xe8 #xed #xee #xef #xec #xdf #x21 #x24 #x2a #x29 #x3b #xac
                            #x2d #x2f #xc2 #xc4 #xc0 #xc1 #xc3 #xc5 #xc7 #xd1 #xa6 #x2c #x25 #x5f #x3e #x3f
                            #xf8 #xc9 #xca #xcb #xc8 #xcd #xce #xcf #xcc #x60 #x3a #x23 #x40 #x27 #x3d #x22
                            #xd8 #x61 #x62 #x63 #x64 #x65 #x66 #x67 #x68 #x69 #xab #xbb #xf0 #xfd #xfe #xb1
                            #xb0 #x6a #x6b #x6c #x6d #x6e #x6f #x70 #x71 #x72 #xaa #xba #xe6 #xb8 #xc6 #xa4
                            #xb5 #x7e #x73 #x74 #x75 #x76 #x77 #x78 #x79 #x7a #xa1 #xbf #xd0 #xdd #xde #xae
                            #x5e #xa3 #xa5 #xb7 #xa9 #xa7 #xb6 #xbc #xbd #xbe #x5b #x5d #xaf #xa8 #xb4 #xd7
                            #x7b #x41 #x42 #x43 #x44 #x45 #x46 #x47 #x48 #x49 #xad #xf4 #xf6 #xf2 #xf3 #xf5
                            #x7d #x4a #x4b #x4c #x4d #x4e #x4f #x50 #x51 #x52 #xb9 #xfb #xfc #xf9 #xfa #xff
                            #x5c #xf7 #x53 #x54 #x55 #x56 #x57 #x58 #x59 #x5a #xb2 #xd4 #xd6 #xd2 #xd3 #xd5
                            #x30 #x31 #x32 #x33 #x34 #x35 #x36 #x37 #x38 #x39 #xb3 #xdb #xdc #xd9 #xda #x9f))
                s))
       (reverse-table (let ((rt (make-array 256 :element-type '(unsigned-byte 8) :initial-element 0)))
                          (loop for char across table for i from 0
                               do (aver (= 0 (aref rt (char-code char))))
                               do (setf (aref rt (char-code char)) i))
                          rt)))
  (define-external-format (:ebcdic-us :ibm-037 :ibm037)
      1 t
    (if (>= bits 256)
        (external-format-encoding-error stream bits)
        (setf (sap-ref-8 sap tail) (aref reverse-table bits)))
    (aref table byte)))


#!+sb-unicode
(let ((latin-9-table (let ((table (make-string 256)))
                       (do ((i 0 (1+ i)))
                           ((= i 256))
                         (setf (aref table i) (code-char i)))
                       (setf (aref table #xa4) (code-char #x20ac))
                       (setf (aref table #xa6) (code-char #x0160))
                       (setf (aref table #xa8) (code-char #x0161))
                       (setf (aref table #xb4) (code-char #x017d))
                       (setf (aref table #xb8) (code-char #x017e))
                       (setf (aref table #xbc) (code-char #x0152))
                       (setf (aref table #xbd) (code-char #x0153))
                       (setf (aref table #xbe) (code-char #x0178))
                       table))
      (latin-9-reverse-1 (make-array 16
                                     :element-type '(unsigned-byte 21)
                                     :initial-contents '(#x0160 #x0161 #x0152 #x0153 0 0 0 0 #x0178 0 0 0 #x20ac #x017d #x017e 0)))
      (latin-9-reverse-2 (make-array 16
                                     :element-type '(unsigned-byte 8)
                                     :initial-contents '(#xa6 #xa8 #xbc #xbd 0 0 0 0 #xbe 0 0 0 #xa4 #xb4 #xb8 0))))
  (define-external-format (:latin-9 :latin9 :iso-8859-15 :iso8859-15)
      1 t
    (setf (sap-ref-8 sap tail)
          (if (< bits 256)
              (if (= bits (char-code (aref latin-9-table bits)))
                  bits
                  (external-format-encoding-error stream byte))
              (if (= (aref latin-9-reverse-1 (logand bits 15)) bits)
                  (aref latin-9-reverse-2 (logand bits 15))
                  (external-format-encoding-error stream byte))))
    (aref latin-9-table byte)))

(define-external-format/variable-width (:utf-8 :utf8) nil
  (let ((bits (char-code byte)))
    (cond ((< bits #x80) 1)
          ((< bits #x800) 2)
          ((< bits #x10000) 3)
          (t 4)))
  (ecase size
    (1 (setf (sap-ref-8 sap tail) bits))
    (2 (setf (sap-ref-8 sap tail)       (logior #xc0 (ldb (byte 5 6) bits))
             (sap-ref-8 sap (+ 1 tail)) (logior #x80 (ldb (byte 6 0) bits))))
    (3 (setf (sap-ref-8 sap tail)       (logior #xe0 (ldb (byte 4 12) bits))
             (sap-ref-8 sap (+ 1 tail)) (logior #x80 (ldb (byte 6 6) bits))
             (sap-ref-8 sap (+ 2 tail)) (logior #x80 (ldb (byte 6 0) bits))))
    (4 (setf (sap-ref-8 sap tail)       (logior #xf0 (ldb (byte 3 18) bits))
             (sap-ref-8 sap (+ 1 tail)) (logior #x80 (ldb (byte 6 12) bits))
             (sap-ref-8 sap (+ 2 tail)) (logior #x80 (ldb (byte 6 6) bits))
             (sap-ref-8 sap (+ 3 tail)) (logior #x80 (ldb (byte 6 0) bits)))))
  (cond ((< byte #x80) 1)
        ((< byte #xc2) (return-from decode-break-reason 1))
        ((< byte #xe0) 2)
        ((< byte #xf0) 3)
        (t 4))
  (code-char (ecase size
               (1 byte)
               (2 (let ((byte2 (sap-ref-8 sap (1+ head))))
                    (unless (<= #x80 byte2 #xbf)
                      (return-from decode-break-reason 2))
                    (dpb byte (byte 5 6) byte2)))
               (3 (let ((byte2 (sap-ref-8 sap (1+ head)))
                        (byte3 (sap-ref-8 sap (+ 2 head))))
                    (unless (and (<= #x80 byte2 #xbf)
                                 (<= #x80 byte3 #xbf))
                      (return-from decode-break-reason 3))
                    (dpb byte (byte 4 12) (dpb byte2 (byte 6 6) byte3))))
               (4 (let ((byte2 (sap-ref-8 sap (1+ head)))
                        (byte3 (sap-ref-8 sap (+ 2 head)))
                        (byte4 (sap-ref-8 sap (+ 3 head))))
                    (unless (and (<= #x80 byte2 #xbf)
                                 (<= #x80 byte3 #xbf)
                                 (<= #x80 byte4 #xbf))
                      (return-from decode-break-reason 4))
                    (dpb byte (byte 3 18)
                         (dpb byte2 (byte 6 12)
                              (dpb byte3 (byte 6 6) byte4))))))))
\f
;;;; 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
         (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)
        (multiple-value-setq (bin-routine bin-type bin-size read-n-characters
                                          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
        (multiple-value-setq (cin-routine cin-type cin-size read-n-characters
                                          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))
      (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)
        (multiple-value-setq (bout-routine bout-type bout-size output-bytes
                                           normalized-external-format)
          (pick-output-routine (if bivalent-stream-p
                                   '(unsigned-byte 8)
                                   target-type)
                               (fd-stream-buffering fd-stream)
                               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
        (multiple-value-setq (cout-routine cout-type cout-size output-bytes
                                           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))
      (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))))))

;; Unix's close(2) can fail in various ways.  FIXME: look around for
;; other calls to UNIX-CLOSE, and maybe replace them with this.
(defun close-descriptor (descriptor &optional signaler)
  "Try to close(2) DESCRIPTOR.  Retry in case close(2) fails and
sets errno to EINTR.  If close(2) fails and sets errno to any
value other than EINTR, then use SIGNALER as follows: if SIGNALER
is a function, call it with the descriptor and errno; if SIGNALER
is T, signal an error of type ERROR; if SIGNALER is NIL, silently
ignore the close(2) error.  (In this case, we can silently leak a
descriptor; don't use this unless you have to.)"
  (loop (multiple-value-bind (status errno)
            (os-close descriptor)
          (if status
              (return)
              (when (/= errno sb!unix:eintr)
                (cond ((functionp signaler)
                       (funcall signaler descriptor errno))
                      ((eq signaler t)
                       (error "failed to close() fd ~D: (~A)"
                              descriptor (strerror errno)))))))))

;;; Handles the resource-release aspects of stream closing, and marks
;;; it as closed.
(defun release-fd-stream-resources (fd-stream)
  (handler-case
      ;; 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.
      (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))
        (close-descriptor (fd-stream-fd fd-stream)
                          (lambda (fd errno)
                            (declare (ignore fd))
                            (simple-stream-perror
                             "failed to close() the descriptor in ~A"
                             fd-stream errno)))
        (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 unread chatacter, and returns
;;; the input buffer, and the amount of of flushed input in bytes.
(defun flush-input-buffer (stream)
  (let ((unread (if (fd-stream-unread stream)
                    1
                    0)))
    (setf (fd-stream-unread stream) nil)
    (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)
  #!+(and win32 win32-uses-file-handles)
  (progn
    (sb!win32:handle-clear-input (fd-stream-fd stream))
    (setf (fd-stream-listen stream) nil))
  #!+(and win32 (not win32-uses-file-handles))
  #!+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
     (setf (fd-stream-unread fd-stream) arg1)
     (setf (fd-stream-listen fd-stream) t))
    (:close
      (when (open-stream-p fd-stream)
        (finish-fd-stream-output fd-stream)
        (release-fd-stream-resources fd-stream)
        (do-after-close-actions fd-stream arg1)))
    (: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
     (= 1 (the (member 0 1)
            (sb!unix:unix-isatty (fd-stream-fd fd-stream)))))
    (:line-length
     80)
    (:charpos
     (fd-stream-char-pos fd-stream))
    (:file-length
     (unless (stream-pathname 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 'file-stream
              :format-control "~S is not a stream associated with a file."
              :format-arguments (list fd-stream)))
     ;; OS-FILE-LENGTH wraps fstat() and GetFileSize(), both of which
     ;; can return NIL and an errno.  Since ANSI says we're to return
     ;; NIL if the length cannot be determined, we just return the
     ;; first value.  (Before 1.0.15 or so, we errored when fstat()
     ;; failed.)
     (truncate (os-file-length (fd-stream-fd fd-stream))
               (fd-stream-element-size fd-stream)))
    (: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)))
    (serve-all-events)))

(defun fd-stream-get-file-position (stream)
  (declare (fd-stream stream))
  (without-interrupts
    (let ((posn (os-seek (fd-stream-fd stream) 0 t)))
      (declare (type (or (alien sb!unix:off-t) 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)))))
        (when (fd-stream-unread stream)
          (decf posn))
        ;; 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:off-t) (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 :start))
               (:end
                (values 0 :end))
               (t
                (values (* position-spec (fd-stream-element-size stream))
                        :start)))
           (declare (type (alien sb!unix:off-t) offset))
           (let ((posn (os-seek (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:off-t))))))))

\f
;;;; MAKE-FD-STREAM

;;; 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.
(defun make-fd-stream (fd
                       &key
                       (input nil input-p)
                       (output nil output-p)
                       (element-type 'base-char)
                       (buffering :full)
                       (external-format :default)
                       timeout
                       input-buffer-p
                       dual-channel-p
                       auto-close
                       pathname
                       truename
                       altname
                       after-close
                       ;; Deprecated slots
                       file
                       (name (if file
                                 (format nil "file ~A" file)
                                 (format nil "descriptor ~W" fd))))
  (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
                                 :buffering buffering
                                 :dual-channel-p dual-channel-p
                                 :external-format external-format
                                 :timeout
                                 (if timeout
                                     (coerce timeout 'single-float)
                                     nil)
                                 :pathname pathname
                                 :truename truename
                                 :altname altname
                                 :after-close after-close
                                 :name name
                                 :file file)))
    (set-fd-stream-routines stream element-type external-format
                            input output input-buffer-p)
    (when (and auto-close (fboundp 'finalize))
      (finalize stream
                (lambda ()
                  ;; FIXME: CLOSE-DESCRIPTOR takes care of EINTR, but
                  ;; should we signal an error for other close()
                  ;; failures here?  I don't know what consequences
                  ;; follow from signalling error during GC.  But if
                  ;; close() fails, we really shouldn't lose track of
                  ;; the fd.
                  (close-descriptor fd)
                  #!+sb-show
                  (format *terminal-io* "** closed file descriptor ~W **~%"
                          fd))
                :dont-save t))
    stream))
\f
;;; Since SUSv3 mkstemp() doesn't specify the mode of the created file
;;; and since we have to implement most of this ourselves for Windows
;;; anyway, it seems worthwhile to depart from the mkstemp()
;;; specification by taking a mode to use when creating the new file.
;;; This was introduced around 1.0.13, was a thin wrapper around a
;;; routine in the runtime, and was used in only a very restricted
;;; way; before 1.0.15, I noticed that there were some drawbacks in
;;; the C library routines in that routine in the runtime that limited
;;; the general-purposeness of that routine, and so rewrote it all in
;;; Lisp; doing it in Lisp also means that the user can control the
;;; randomness manually, if necessary.
(defvar *random-filename-random-state* nil
  "Random-state used when creating random filenames.  SETF-able,
if you want to produce a predictable sequence of filenames.  If
NIL, generating the next random filename will assign this
variable a new, randomly generated random-state.")

(defun random-filename (template-string)
  (unless *random-filename-random-state*
    (setf *random-filename-random-state* (make-random-state t)))
  (let* (;; mkstemp() uses POSIX's so-called "portable filename
         ;; character set" for filling the template.  We exclude #\.,
         ;; since that's our pathname type separator.
         (random-charset #.(format nil "~@{~A~}"
                                   "abcdefghijklmnopqrstuvwxyz"
                                   "ABCDEFGHIJKLMNOPQRSTUVWXYZ"
                                   "1234567890" "-_"))
         (X-pos (1+ (position #\X template-string :test 'char/= :from-end t)))
         (template-length (- (length template-string) X-pos))
         (template-stem (subseq template-string 0 X-pos)))
    (unless (>= template-length 6)
      (error "bad mkstemp template ~A" template-string))
    (let ((random-suffix (loop
                           repeat template-length
                           collect (elt
                                     random-charset
                                     (random
                                       64 *random-filename-random-state*)))))
      (concatenate 'string template-stem random-suffix))))
\f
;;; OPEN

;; Circa 1.0.14, the innards of OPEN have been entirely rewritten from
;; the CMU code, with a few goals in mind: (1) to be usable as a
;; substrate for more than one streams API, to prevent functionality
;; skew; (2) to be asynch-interrupt-safe and slightly less prone to
;; breakage due to fork(), (3) to try to do as much as possible using
;; Lisp-level file system functions, rather than raw Unix system
;; calls, so that we have some stress-testing on that code, so that we
;; get consistent, Lisp-level error detection and reporting when
;; things go awry, and since some of the system calls' behaviors vary
;; a bit across Unix and Windows.

;; When we construct a stream, we store a function to be called during
;; CLOSE, and also a PID.  This routine runs the close-time code,
;; after the descriptor is closed, in case this process is responsible
;; for that task.
(defun do-after-close-actions (stream abortp)
  (when (and #!+unix (eql (sb!unix:unix-getpid) (stream-owner-pid stream))
             (stream-after-close stream))
    (with-simple-restart (continue "Continue, leaving files in place.")
      (funcall (stream-after-close stream) stream abortp))
    (setf (stream-after-close stream) nil)))

;; We have separate functions for actions to be performed after
;; constructing the stream, but before returning it to the user.  The
;; only one that's common to all ways of building SBCL is the one that
;; repositions the file pointer after constructing the stream.
(defun open-if-exists-append (stream)
  (file-position stream :end))

(defvar *open-backup-suffix* ".bak"
  "Backup suffix used when opening with :RENAME.")

(defun open-backup-pathname (pathname)
  "Return the name that a file whose truename is PATHNAME will have
after a successful :RENAME opening.  Note that this is a syntactic
operation, and does not examine the file system; if PATHNAME names a
symlink, calling OPEN on PATHNAME with IF-EXISTS :RENAME will rename a
file whose truename is not PATHNAME."
  (parse-native-namestring
   (concatenate 'string (native-namestring pathname) *open-backup-suffix*)
   (pathname-host pathname)))

(defun close-abort-delete (stream abortp)
  "During an aborting close, delete the file associated with the
   stream."
  (when abortp
    (delete-file (stream-truename stream))))

(defun make-deleted-file-closer (stream)
  (let ((old-after-close (stream-after-close stream)))
    (lambda (stream abort)
      (declare (ignore abort))
      (if (member old-after-close
                  #!+open-lazy-file-disposition
                  '(#'close-lazy-supersede #'close-lazy-rename)
                  #!-open-lazy-file-disposition
                  '(#'close-delete-altname #'close-rename-altname))
          (funcall old-after-close stream t)
          (delete-file (stream-truename stream))))))

;; NTFS supports hard links, and some Unixes can mount file systems
;; that don't (e.g., FAT).  So try linking first on both Unix and
;; Windows, and then fail over to renaming.
(defun make-temporary-name-for-file (pathname)
  "Link or rename PATHNAME to a random name in the same
directory.  If file does not exist, returns NIL.  Otherwise,
returns the random name and a boolean that's true in case the
file was renamed, rather than linked."
  (loop with filename = (native-namestring pathname)
        for temppath = (parse-native-namestring
                        (random-filename
                         (concatenate 'string filename "-XXXXXX"))
                        (pathname-host pathname))
        thereis (handler-case (link-file pathname temppath)
                  (file-does-not-exist () (return nil))
                  (file-exists () nil)
                  (file-error ()
                    (let ((new-name
                           (replace-file pathname temppath)))
                      (values new-name t))))))

;; FIXME: rewrite this, to make it clearer that this is
;; transaction-like?
(defmacro with-temporary-name-for-file ((var pathname) &body body)
  "Run BODY with VAR bound to a new, randomly selected name for
the file named by PATHNAME.  If control leaves body abnormally,
try to restore FILE to its old name.  Otherwise, the file named
by PATHNAME at the start of BODY will be named by the value of
VAR after the body."
  (with-unique-names (oldname renamedp)
    `(let ((,oldname ,pathname))
       (multiple-value-bind (,var ,renamedp)
           (make-temporary-name-for-file ,oldname)
         (unwind-protect
             (multiple-value-prog1 (progn ,@body) (setf ,var nil))
           (when ,var
             (if ,renamedp
                 (rename-file ,var ,oldname)
                 (delete-file ,var))))))))

;; The actions to conduct at OPEN- and CLOSE-time differ slightly in
;; the lazy/non-lazy file disposition worlds.  In fact, the same basic
;; things happen, just at different times.
#!-open-lazy-file-disposition
(progn
  (defun open-eager-rename (stream)
    "For openings that create a file with mkstemp(), rename the new
     file to have its final name before returning a stream to the
     user, and modify the stream so that a previously existing file
     gets renamed or deleted at CLOSE-time."
    (with-temporary-name-for-file (temp-name (stream-altname stream))
      (rename-file (stream-truename stream)
                   (merge-pathnames (stream-altname stream)
                                    (make-pathname :type :unspecific)))
      (setf (stream-truename stream) (stream-altname stream)
            (stream-altname stream) temp-name)))

  (defun close-rename-altname (stream abortp)
    "When closing a stream opened with IF-EXISTS :RENAME either
     restore or rename the file that existed before the stream was
     opened."
    (when abortp
      ;; FIXME: Win32's MoveFileEx can atomically rename files.  I
      ;; don't know whether that's how RENAME-FILE should be
      ;; implemented, but we can use it here, in any case.
      #+win32 (delete-file (stream-truename stream))
      (rename-file (stream-altname stream) (stream-truename stream))
      (return-from close-rename-altname))
    (rename-file (stream-altname stream)
                 (merge-pathnames (open-backup-pathname
                                   (stream-truename stream))
                                  (make-pathname :type :unspecific))))

  (defun close-delete-altname (stream abortp)
    "When closing a stream opened with IF-EXISTS :RENAME-AND-DELETE,
     either restore or delete the file that existed before the stream
     was opened.  If SBCL was built with the
     feature :OPEN-SUPERSEDE-IS-RENAME-AND-DELETE, this gets called
     during a CLOSE of a stream opened with :SUPERSEDE, too."
    (when abortp
      ;; FIXME: Win32's MoveFileEx can atomically rename files.  I
      ;; don't know whether that's how RENAME-FILE should be
      ;; implemented, but we can use it here, in any case.
      #+win32 (delete-file (stream-truename stream))
      (rename-file (stream-altname stream) (stream-truename stream))
      (return-from close-delete-altname))
    (delete-file (stream-altname stream)))

  (defun close-delete-pathname (stream abortp)
    "During an aborting close, delete the file named by the name
     used to open the stream.  (This behavior makes no sense, but
     it's what CMU/SBCL has always done for :SUPERSEDE.)"
    (when abortp
      (delete-file (pathname stream)))))

;; Note that in the :OPEN-LAZY-FILE-DISPOSITION world, an opening that
;; creates a new file doesn't touch any existing file until CLOSE-time.
#!+open-lazy-file-disposition
(progn
  (defun close-lazy-supersede (stream abortp)
    "When closing a stream opened with IF-EXISTS :RENAME-AND-DELETE,
     either rename the file associated with the stream into place, or
     delete the file associated with the stream.  If SBCL was built
     with the feature :OPEN-SUPERSEDE-IS-RENAME-AND-DELETE, this gets
     called during a CLOSE of a stream opened with :SUPERSEDE, too."
    (when abortp
      (delete-file (stream-truename stream))
      (return-from close-lazy-supersede))
    (rename-file (stream-truename stream) (stream-altname stream))
    (setf (stream-truename stream) (stream-altname stream)))

  (defun close-lazy-rename (stream abortp)
    "When closing a stream opened with IF-EXISTS :RENAME-AND-DELETE,
     either rename the file associated with the stream into place and
     rename the old file to the backup name, or delete the file
     associated with the stream."
    (when abortp
      (delete-file (stream-truename stream))
      (return-from close-lazy-rename))
    (let ((backup-path (merge-pathnames (open-backup-pathname
                                         (stream-altname stream))
                                        (make-pathname :type :unspecific)))
          link-path)
      (with-temporary-name-for-file (temp-name (stream-altname stream))
        (rename-file (stream-truename stream) (stream-altname stream))
        (setf link-path temp-name ;hold onto TEMP-NAME for use below.
              (stream-truename stream) (stream-altname stream)))
      ;; We do this final rename outside of
      ;; WITH-TEMPORARY-NAME-FOR-FILE so that if it fails, no data
      ;; will have been lost (though the old file will be left with a
      ;; random name if the user aborts).
      (when link-path
        (rename-file link-path backup-path)))))

(defun open-element-type-satisfies-function (type)
  (or (member type '(:default unsigned-byte signed-byte))
      (subtypep type 'character)
      ;; XXX: this should be a /finite/ subtype of integer, but I
      ;; don't know if we are able to say that.
      (subtypep type 'integer)))

;; I think this macro captures the common aspect of calling a
;; VALUES-FORM that returns values that include something that must
;; not be allowed to leak.  FIXME: some other places could perhaps
;; take advantage of this (e.g., the temporary file descriptor used in
;; RUN-PROGRAM).
(defmacro uninterruptibly-bind-and-protect
    ((&rest vars) values-form form &body cleanup-forms)
  "Bind VARS to the return values of VALUES-FORM, evaluate FORM
and then CLEANUP-FORMS with VARS so bound; CLEANUP-FORMS will be
run even if control transfers out of FORM abnormally.
Asynchronous interrupts are enabled during FORM, and nowhere
else."
  `(without-interrupts
     (multiple-value-bind ,vars ,values-form
       (unwind-protect
            (with-local-interrupts ,form)
         ,@cleanup-forms))))

;; The following function, OPEN-FILE, is a high-level internal
;; primitive that's meant to do all the work of OPEN except for
;; constructing a stream.  It's designed to suit the needs of
;; FD-STREAMS and SB-SIMPLE-STREAMS, but should also suffice for other
;; ways of implementing ANSI FILE-STREAMs.
;;
;; Note: as far as I can tell, any call to a function that returns a
;; file descriptor while interrupts are enabled exposes a window
;; during which an asynchronous interrupt can lead to fd leak.  So
;; while OPEN-FILE must disable interrupts around open() calls, we
;; don't want to its callers to have to disable interrupts around
;; OPEN-FILE, since OPEN-FILE must do various other error-prone things
;; (e.g., resolving truenames).  So in order to allow our callers to
;; be ignorant of asynchronous interrupt concerns, we don't have
;; OPEN-FILE return a descriptor, but instead have it assign a special
;; variable as described in the docstring.
(defun open-file
    (filespec direction if-does-not-exist if-exists element-type
     os-open-args)
  "Open a file according to OPEN-like arguments.  FILESPEC is the
   verbatim (unmerged, untranslated) argument to OPEN.  DIRECTION
   and ELEMENT-TYPE are the arguments supplied to or defaulted in
   OPEN.  IF-DOES-NOT-EXIST and IF-EXISTS are the arguments
   supplied to OPEN, or the symbol SB-IMPL::DEFAULT if the
   argument was not supplied.  OS-OPEN-ARGS is an
   OS-OPEN-ARGUMENTS list, containing any extra arguments to be
   passed down to the system's open syscall.

   Callers must bind *FILE-DESCRIPTOR* in the dynamic
   environment.  If OPEN-FILE succeeds, it sets *FILE-DESCRIPTOR*
   to an integer, and returns seven values to be used in the
   caller:

   1. the result of merging FILESPEC,

   2. the name of the file actually open,

   3. a pathname or NIL, used as bookkeeping for some kinds of
      openings,

   4. a boolean that's true if the stream is for input,

   5. a boolean that's true if the stream is for output,

   6. a function of one argument to call on the to-be-created
      stream before returning it to the user,

   7. a function of two arguments to be called after closing the
      descriptor during CLOSE; the first argument to this
      function is the stream, the second a generalized boolean
      that's true in case the stream is being closed in an
      aborting manner.

   The caller is responsible for constructing a stream, calling
   the first function, and arranging for the second function to
   be called during CLOSE.

   If OPEN-FILE does not open a file, either because IF-EXISTS
   and IF-DOES-NOT-EXIST inhibit opening or because of file
   system errors during open(), OPEN-FILE will return NIL or
   signal a FILE-ERROR, as determined by the arguments and file
   system state.

   If OPEN-FILE signals an error or returns NIL,
   *FILE-DESCRIPTOR* will have the value NIL after control
   returns from OPEN-FILE.

   If any error occurs after a file has been opened, OPEN-FILE
   will close the descriptor.

   Note that OPEN-FILE can signal FILE-ERRORs not directly
   related to a call to open(): truename resolution, pathname
   unparsing, logical pathname translation, etc. can all error."
  (declare (type (member :input :output :io :probe) direction))
  (declare (type (satisfies open-element-type-satisfies-function)
                 element-type))
  (declare (ignore element-type))

  ;; This is our internal protocol.
  (unless (boundp '*file-descriptor*)
    (bug "*FILE-DESCRIPTOR* is not bound at start of OPEN-FILE."))

  ;; Basic sanity stuff first.  Should be straightforward
  ;; transcriptions of things from the CLHS.
  (setf filespec (pathname filespec))
  (when (wild-pathname-p filespec)
    (error 'simple-file-error
           :pathname filespec
           :format-control "can't open a wild pathname: ~A"
           :format-arguments (list filespec)))
  (when (eq if-exists 'default)
    (if (member direction '(:output :io))
        (setf if-exists (if (eq (pathname-version filespec) :newest)
                            :new-version
                            :error))
        (setf if-exists nil)))
  (when (eq if-does-not-exist 'default)
    (setf if-does-not-exist
          (cond
            ((eq direction :probe)
             nil)
            ((or (eq direction :input)
                 (member if-exists '(:overwrite :append
                                     #!+cdr-5 :truncate)))
             :error)
            ((and (member direction '(:output :io))
                  (not (member if-exists '(:overwrite :append
                                           #!+cdr-5 :truncate))))
             :create))))
  (check-type if-does-not-exist (member :create :error nil))
  (check-type if-exists (member :new-version :supersede
                                :rename :rename-and-delete
                                :overwrite :append
                                :error nil
                                #!+cdr-5 :truncate))

  (labels ((fail (errno)
             (simple-file-perror "cannot open ~A" filespec errno))
           (fail-if (boolean errno)
             (if boolean
                 (fail errno)
                 (return-from open-file nil)))
           (open-bug (existsp)        ;This hasn't happened yet, in fact.
             (bug "~&This can't happen. ~
                     The file does~:[ not~;~] exist.~%
                     DIRECTION: ~A~%~
                     IF-DOES-NOT-EXIST: ~A~%~
                     IF-EXISTS: ~A~%"
                  existsp direction if-does-not-exist if-exists))
           (compute-os-open-arguments (existsp)
             "Using the defaulted arguments to OPEN-FILE in the
              lexical environment and a boolean that's true if
              and only if the file exists, compute the arguments
              to the OS's opening syscall."
             ;; Remember that IF-EXISTS actions are to be carried out
             ;; only when the file already exists, so, e.g., :I-D-N-E
             ;; :CREATE :I-E :APPEND doesn't get :APPEND's special
             ;; treatment if the file doesn't yet exist.  Note also
             ;; that because we determine whether the file exists
             ;; before calling this, this code only gets run in case
             ;; we actually try opening something, e.g., we don't run
             ;; this when the file does not exist and
             ;; IF-DOES-NOT-EXIST is NIL or :ERROR.
             (merge-os-open-arguments
              #!-win32-uses-file-handles
              (%make-os-open-arguments
               :flags (logior
                       (ecase direction
                         (:input  sb!unix:o_rdonly)
                         (:probe  sb!unix:o_rdonly)
                         (:output sb!unix:o_wronly)
                         (:io     sb!unix:o_rdwr))
                       (if existsp
                           (if (member direction '(:output :io))
                               (ecase if-exists
                                 (:append sb!unix:o_append)
                                 ((:rename :rename-and-delete)
                                  (logior sb!unix:o_creat sb!unix:o_excl))
                                 (:supersede
                                  #!+open-supersede-is-rename-and-delete
                                  (logior sb!unix:o_creat sb!unix:o_excl)
                                  #!-open-supersede-is-rename-and-delete
                                  sb!unix:o_trunc)
                                 #!+cdr-5
                                 (:truncate sb!unix:o_trunc)
                                 (:overwrite 0))
                               0)
                           (if (eq if-does-not-exist :create)
                               (logior sb!unix:o_creat sb!unix:o_excl)
                               0))))
              ;; Win32's CreateFile seems to be able to do all the
              ;; basic stuff that we have POSIX open() do; it just
              ;; organizes the details differently.
              #!+win32-uses-file-handles
              (%make-os-open-arguments
               :desired-access
               (ecase direction
                 (:input  sb!win32:generic_read)
                 (:probe  0)
                 (:output (if (and existsp (eq if-exists :append))
                              (logandc2 sb!win32:generic_write
                                        sb!win32:file_write_data)
                              sb!win32:generic_write))
                 (:io     (logior sb!win32:generic_read
                                  (if (and existsp (eq if-exists :append))
                                      (logandc2 sb!win32:generic_write
                                                sb!win32:file_write_data)
                                      sb!win32:generic_write))))
               :creation-disposition
               (if existsp
                   (if (member direction '(:output :io))
                       (ecase if-exists
                         ((:overwrite :append) sb!win32:open_existing)
                         ((:rename :rename-and-delete)
                          sb!win32:create_new)
                         #!-open-supersede-is-rename-and-delete
                         (:supersede sb!win32:truncate_existing)
                         #!+open-supersede-is-rename-and-delete
                         (:supersede sb!win32:create_new)
                         #!+cdr-5
                         (:truncate sb!win32:truncate_existing))
                       sb!win32:open_existing)
                   (if (eq if-does-not-exist :create)
                       sb!win32:create_new
                       0)))
              os-open-args))
           (random-pathname (pathname)
             (parse-native-namestring
              (random-filename
               (concatenate 'string (native-namestring pathname) "-XXXXXX"))
              (pathname-host pathname)))
           (ensure-extant-nondirectory-file (truename)
             (multiple-value-bind (targetp errno ino mode)
                 (sb!unix:unix-stat (native-namestring truename))
               (declare (ignore ino))
               (unless targetp
                 (fail errno))
               (when (= (logand mode sb!unix:s-ifmt) sb!unix:s-ifdir)
                 (fail sb!unix:eisdir))))
           (%open (truename os-open-arguments)
             (locally (declare (special *file-descriptor*))
               (setf *file-descriptor* nil)
               (let ((filename (native-namestring truename)))
                 (uninterruptibly-bind-and-protect (file-descriptor errno)
                     (os-open filename os-open-arguments)
                     (if file-descriptor
                         (progn
                           (setf *file-descriptor* file-descriptor
                                 file-descriptor nil)
                           t)
                         (fail errno))
                   ;; Cleanup forms.
                   (when file-descriptor
                     (close-descriptor file-descriptor t)
                     (setf *file-descriptor* nil)
                     #|(when (eq if-does-not-exist :create)
                     (delete-file truename))|#)))))
           (merged-pathname ()
             (let ((pathname (merge-pathnames filespec)))
               (if (eq (car (pathname-directory pathname)) :absolute)
                   pathname
                   (if (typep pathname 'logical-pathname)
                       ;; Relative logical pathnames can, in principle,
                       ;; have translations (though programmers who
                       ;; write programs that rely on such translations
                       ;; would steal sheep).
                       pathname
                       ;; Note that getcwd(3) can fail on traditional
                       ;; Unices.  In that case, we can't get a full
                       ;; pathname for the user, even if we can open the
                       ;; file.
                       (let ((cwd (ignore-errors
                                    #!+unix (sb!unix:posix-getcwd)
                                    #!+win32 (sb!win32:get-current-directory)))
                             (host (pathname-host filespec)))
                         (if cwd
                             (let ((cwd-pathname
                                    (parse-native-namestring
                                     cwd host nil :as-directory t)))
                               (merge-pathnames pathname cwd-pathname))
                             pathname))))))
           (input-p ()
             (not (not (member direction '(:input :probe :io)))))
           (output-p ()
             (not (not (member direction '(:io :output)))))
           (create-beside (truename os-open-arguments)
             (loop for random-pathname = (random-pathname truename)
                   until (handler-case
                             (%open random-pathname os-open-arguments)
                           (file-exists () nil))
                   finally (return
                             (values
                              (merged-pathname) random-pathname
                              ;; For files created under a random
                              ;; name, eventually call RENAME-FILE,
                              ;; which implicitly merges.  So we
                              ;; reparse the unparsed TRUENAME in
                              ;; order to normalize pathnames like
                              ;; #S(pathname :name "abc.def" :type
                              ;; nil), which will rename wrong with
                              ;; the parse of "abc.def-XXXXXX".
                              (parse-native-namestring
                               (native-namestring truename)
                               (pathname-host truename))
                              (input-p) (output-p)
                              (if (eq direction :probe) #'close
                                  #!-open-lazy-file-disposition
                                  #'open-eager-rename)
                              ;; Note: if :NEW-VERSION is ever
                              ;; changed to create a new file when
                              ;; one already exists, decide whether
                              ;; it should be like :RENAME or
                              ;; :RENAME-AND-DELETE, and then
                              ;; change both these two forms.
                              #!-open-lazy-file-disposition
                              (if (eq if-exists :rename)
                                  #'close-rename-altname
                                  #'close-delete-altname)
                              #!+open-lazy-file-disposition
                              (if (eq if-exists :rename)
                                  #'close-lazy-rename
                                  #'close-lazy-supersede)))))
           (open-extant (truename os-open-arguments)
             (when (%open truename os-open-arguments)
               (values (merged-pathname) truename nil
                       (input-p) (output-p)
                       (cond ((eq direction :probe) #'close)
                             ((and (member direction '(:output :io))
                                   (eq if-exists :append))
                              #'open-if-exists-append))
                       ;; Bizarre, unnecessary
                       ;; historical behavior.
                       #|#!-open-supersede-is-rename-and-delete
                       (if (and (member direction '(:output :io))
                                (eq if-exists :supersede))
                           #'close-delete-pathname)|#)))
           #!-open-lazy-file-disposition
           (create-in-place (truename os-open-arguments)
             (when (%open truename os-open-arguments)
               (values (merged-pathname) truename nil
                       (input-p) (output-p)
                       (if (eq direction :probe) #'close)
                       #'close-abort-delete)))
           ;; On Windows, we can't generally rename a file while it's
           ;; open, so we ensure an existing file is out of the way
           ;; and create in place.
           #!+(and win32 (not open-lazy-file-disposition))
           (win32-lossy-create-beside (truename os-open-arguments)
             (with-temporary-name-for-file (temp-name truename)
               (ignore-errors (delete-file truename))
               (when (%open truename os-open-arguments)
                 (values (merged-pathname) truename temp-name
                         (input-p) (output-p)
                         nil (if (eq if-exists :rename)
                                 #'close-rename-altname
                                 #'close-delete-altname))))))
    (let* ((truename (handler-case (probe-file filespec)
                       (file-error (e)
                         (if (eq if-does-not-exist nil)
                             (return-from open-file nil)
                             (signal e))))))
      (if truename
          ;; We know the file exists.
          (cond ((or (member direction '(:input :probe))
                     (member if-exists
                             '(:overwrite :append
                               #!+cdr-5 :truncate
                               #!-open-supersede-is-rename-and-delete
                               :supersede)))
                 (open-extant truename (compute-os-open-arguments t)))
                ((and (member direction '(:output :io))
                      (member if-exists
                              '(:rename :rename-and-delete
                                #!+open-supersede-is-rename-and-delete
                                :supersede)))
                 (ensure-extant-nondirectory-file truename)
                 #!-(and win32 (not open-lazy-file-disposition))
                 (create-beside truename (compute-os-open-arguments t))
                 #!+(and win32 (not open-lazy-file-disposition))
                 (win32-lossy-create-beside
                  truename (compute-os-open-arguments t)))
                ((and (member direction '(:output :io))
                      (member if-exists '(:error nil :new-version)))
                 (fail-if (member if-exists '(:error :new-version))
                          #!-win32-uses-file-handles
                          sb!unix:eexist
                          #!+win32-uses-file-handles
                          sb!win32:error_file_exists))
                (t (open-bug t)))
          (let ((truename (translate-logical-pathname
                           (merge-pathnames filespec))))
            (cond ((eq if-does-not-exist :create)
                   #!-open-lazy-file-disposition
                   (create-in-place
                    truename (compute-os-open-arguments nil))
                   #!+open-lazy-file-disposition
                   (create-beside truename (compute-os-open-arguments nil)))
                  ((member if-does-not-exist '(:error nil))
                   (fail-if (eq if-does-not-exist :error) sb!unix:enoent))
                  (t (open-bug nil))))))))

(defun open (pathspec &rest keys
             &key
             (direction :input) (element-type 'character)
             (if-exists nil if-exists-supplied-p)
             (if-does-not-exist nil if-does-not-exist-supplied-p)
             (external-format :default))
  #!+sb-doc
  #.(format
     nil "~@{~A~}"
     "Return a stream which reads from or writes to PATHSPEC.
  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,
                       :SUPERSEDE, :OVERWRITE, :APPEND, "
     #!+cdr-5 ":TRUNCATE "
     "or NIL.
   :IF-DOES-NOT-EXIST - one of :ERROR, :CREATE or NIL."
     ;; FIXME: document things in the manual.
     #+nil"  See the manual for details.")
  (let (*file-descriptor*) ;OPEN-FILE sets this.
    (declare (special *file-descriptor*))
    (multiple-value-bind (pathname truename altname
                                   input output init-func close-func)
        (open-file
         pathspec
         direction
         (if if-does-not-exist-supplied-p if-does-not-exist 'default)
         (if if-exists-supplied-p if-exists 'default)
         ;; Unix doesn't care about the element type, but Windows
         ;; might, one day.
         element-type
         ;; We extract keyword arguments this way in order to force
         ;; the user to say :ALLOW-OTHER-KEYS T to take advantage of
         ;; this extension.
         (apply #'make-os-open-arguments keys))
      (unwind-protect
           (when *file-descriptor*
             (let ((stream (make-fd-stream *file-descriptor*
                                           :input input
                                           :output output
                                           :element-type element-type
                                           :external-format external-format
                                           :pathname pathname
                                           :truename truename
                                           :altname altname
                                           :dual-channel-p nil
                                           :input-buffer-p t
                                           :after-close close-func
                                           :auto-close t)))
               ;; Now that the descriptor is stored in the stream,
               ;; CLOSE and the stream finalizer are responsible for
               ;; closing the descriptor.
               (setf *file-descriptor* nil)
               (when init-func
                 (handler-case (funcall init-func stream)
                   ;; If the INIT-FUNC fails (e.g., if the user tries an
                   ;; :APPEND opening on an unseekable file), close the
                   ;; stream now, rather than waiting until GC.
                   (error (e)
                     (close stream :abort t)
                     (signal e))))
               stream))
        (when *file-descriptor*
          (close-descriptor *file-descriptor* t))))))

;; SB-SIMPLE-STREAMS wants a hook for opening an FD-STREAM, but it
;; redefines OPEN, so rather than have it duplicate the above, we'll
;; give it this.  Also, any other internal stuff that needs to get an
;; FD-STREAM with OPEN-like interface can use this.
(setf (fdefinition 'open-fd-stream) #'open)
\f
;; RUN-PROGRAM needs to create pipes, so ISTM to be better to hide the
;; differences between descriptors and handles here.
(defun open-pipe (&key (external-format :default))
  (uninterruptibly-bind-and-protect (read/nil write/errno)
      #!-win32-uses-file-handles
      (sb!unix:unix-pipe)
       #!+win32-uses-file-handles
      (sb!win32:create-pipe
       (sb!win32:make-security-attributes nil 1) 0)
    ;; FIXME: this form is interruptible; do we end up returning a
    ;; stream that wraps a closed pipe in case of interrupt?
    (if read/nil
        (let (read-stream write-stream)
          (setf read-stream (make-fd-stream
                             read/nil :input t
                             :name (format nil "input pipe ~D" read/nil)
                             :buffering :none
                             :element-type :default
                             :external-format external-format)
                read/nil nil
                write-stream (make-fd-stream
                              write/errno :output t
                              :name (format nil "output pipe ~D" write/errno)
                              :buffering :none
                              :element-type :default
                              :external-format external-format)
                write/errno nil)
          (values read-stream write-stream))
        ;; FIXME: this can't be a FILE-ERROR, since there's no
        ;; pathname involved.  STREAM-ERROR?  IPC-ERROR?
        (error "can't create pipe: ~A"
               #!+win32-uses-file-handles
               (sb!win32:get-last-error-message write/errno)
               #!-win32-uses-file-handles
               (strerror write/errno)))
    (unwind-protect
        (when read/nil
          (close-descriptor read/nil t))
      (when write/errno
        (close-descriptor write/errno t)))))

\f
;;;; 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*))))

;;; 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)))
  (multiple-value-bind (stdin stdout stderr)
      #!-win32-uses-file-handles (values 0 1 2)
      #!+win32-uses-file-handles (sb!win32:get-initial-handles)
      #| FIXME: what if some of these win32 handles is invalid? |#
      (/primitive-print "/got handles")
      (/hexstr stdin)
      (/hexstr stdout)
      (/hexstr stderr)
      (with-output-to-string (*error-output*)
        (setf *stdin*
              (make-fd-stream
               stdin :name "standard input" :input t :buffering :line
               #!+win32 :external-format
               #!+win32 (sb!win32::console-input-codepage)))
        (setf *stdout*
              (make-fd-stream
               stdout :name "standard output" :output t :buffering :line
               #!+win32 :external-format
               #!+win32 (sb!win32::console-output-codepage)))
        (setf *stderr*
              (make-fd-stream
               stderr :name "standard error" :output t :buffering :line
               #!+win32 :external-format
               #!+win32 (sb!win32::console-output-codepage)))
        (/primitive-print "/constructed *stdin*, *stdout*, *stderr*")
        (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
                                    :auto-close t))
              (setf *tty* (make-two-way-stream *stdin* *stdout*))))
        (princ (get-output-stream-string *error-output*) *stderr*)))
  (values))
\f
;;;; miscellany

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