X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffd-stream.lisp;h=655ee641013c41a287a176ba89e87f489142954a;hb=95591ed483dbb8c0846c129953acac1554f28809;hp=374d10bee741db199582187a56236e9300ea78f8;hpb=34652b637f023fb24cf76df53e6a1936e94ce9ec;p=sbcl.git

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 374d10b..655ee64 100644
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -16,12 +16,29 @@
 ;;;; 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.
+;;;; 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)))
@@ -53,8 +70,8 @@
   ;;
   ;; ...again, once we have smarted locks the spinlock here can become
   ;; a mutex.
-  `(sb!thread::call-with-system-spinlock (lambda () ,@body)
-                                         *available-buffers-spinlock*))
+  `(sb!thread::with-system-spinlock (*available-buffers-spinlock*)
+     ,@body))
 
 (defconstant +bytes-per-buffer+ (* 4 1024)
   #!+sb-doc
@@ -65,8 +82,11 @@
   (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)))
+                         (deallocate-system-memory sap size))
+                :dont-save t)
       buffer)))
 
 (defun get-buffer ()
@@ -97,7 +117,7 @@
   (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 (bufferp item)
+                       when (buffer-p item)
                        collect (reset-buffer item))))
     (when ibuf
       (push (reset-buffer ibuf) queue))
@@ -165,7 +185,12 @@
   ;; pathname of the file this stream is opened to (returned by PATHNAME)
   (pathname nil :type (or pathname null))
   (external-format :default)
-  (output-bytes #'ill-out :type function))
+  ;; fixed width, or function to call with a character
+  (char-size 1 :type (or fixnum function))
+  (output-bytes #'ill-out :type function)
+  ;; a boolean indicating whether the stream is bivalent.  For
+  ;; internal use only.
+  (bivalent-p nil :type boolean))
 (def!method print-object ((fd-stream fd-stream) stream)
   (declare (type stream stream))
   (print-unreadable-object (fd-stream stream :type t :identity t)
@@ -181,16 +206,19 @@
     (error ":END before :START!"))
   (when (> end start)
     ;; Copy bytes from THING to buffers.
-    (flet ((copy-to-buffer (buffer offset count)
-             (declare (buffer buffer) (index offset count))
+    (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 offset count))
+                  (system-area-ub8-copy thing start sap tail count))
                  ((simple-unboxed-array (*))
-                  (copy-ub8-to-system-area thing start sap offset count))))
-             (incf (buffer-tail buffer) count)
+                  (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
@@ -202,12 +230,13 @@
              (copy-to-buffer obuf tail (min space (- end start)))
              (go :more-output-p)))
        :flush-and-fill
-         ;; Later copies always have an empty buffer, since they are freshly
-         ;; flushed.
+         ;; 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))
-                (offset (buffer-tail obuf)))
-           (aver (zerop offset))
-           (copy-to-buffer obuf offset (min (buffer-length obuf) (- end start))))
+                (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))))))
@@ -237,20 +266,24 @@
                (synchronize-stream-output stream)
                (let ((length (- tail head)))
                  (multiple-value-bind (count errno)
-                     (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap obuf) head length)
+                     (sb!unix:unix-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.
-                          (incf (buffer-head obuf) count)
+                          ;; 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)))))))))))
+                          (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)
@@ -286,8 +319,10 @@
               (head (buffer-head buffer))
               (length (- (buffer-tail buffer) head)))
          (declare (index head length))
+         (aver (>= length 0))
          (multiple-value-bind (count errno)
-            (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap buffer) head length)
+             (sb!unix:unix-write (fd-stream-fd stream) (buffer-sap buffer)
+                                 head length)
            (cond ((eql count length)
                   ;; Complete write, see if we can do another right
                   ;; away, or remove the handler if we're done.
@@ -303,7 +338,8 @@
                  (count
                   ;; Partial write. Update buffer status and requeue.
                   (aver (< count length))
-                  (incf (buffer-head buffer) (or count 0))
+                  ;; 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
@@ -315,8 +351,9 @@
                   (simple-stream-perror "Couldn't write to ~S." stream errno)
                   #!-win32
                   (if (= errno sb!unix:ewouldblock)
-                      (bug "Unexpected blocking write in WRITE-OUTPUT-FROM-QUEUE.")
-                      (simple-stream-perror "Couldn't write to ~S" stream errno))))))))
+                      (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
@@ -384,12 +421,14 @@
 
 (defun stream-decoding-error (stream octets)
   (error 'stream-decoding-error
+         :external-format (stream-external-format stream)
          :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
+         :external-format (stream-external-format stream)
          :stream stream
          :code code))
 
@@ -416,7 +455,7 @@
     (attempt-resync ()
       :report (lambda (stream)
                 (format stream
-                        "~@<Attempt to resync the stream at a character ~
+                        "~@<Attempt to resync the stream at a ~
                         character boundary and continue.~@:>"))
       (fd-stream-resync stream)
       nil)
@@ -454,29 +493,30 @@
 (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)))))
+        (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)
-                   (+ (buffer-tail obuf) size))
-            (setf obuf (flush-output-buffer ,stream-var))))
+         `(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
-              (incf (buffer-tail obuf) size))
+              (setf (buffer-tail obuf) (+ tail size)))
            `(progn
              ,@body
-             (incf (buffer-tail obuf) size)))
+             (setf (buffer-tail obuf) (+ tail size))))
       ,(ecase (car buffering)
          (:none
           `(flush-output-buffer ,stream-var))
@@ -489,21 +529,22 @@
 (defmacro output-wrapper ((stream size buffering restart) &body body)
   (let ((stream-var (gensym "STREAM")))
     `(let* ((,stream-var ,stream)
-            (obuf (fd-stream-obuf ,stream-var)))
+            (obuf (fd-stream-obuf ,stream-var))
+            (tail (buffer-tail obuf)))
       ,(unless (eq (car buffering) :none)
-         `(when (< (buffer-length obuf)
-                   (+ (buffer-tail obuf) ,size))
-            (setf obuf (flush-output-buffer ,stream-var))))
+         `(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
-              (incf (buffer-tail obuf) ,size))
+              (setf (buffer-tail obuf) (+ tail ,size)))
            `(progn
              ,@body
-             (incf (buffer-tail obuf) ,size)))
+             (setf (buffer-tail obuf) (+ tail ,size))))
       ,(ecase (car buffering)
          (:none
           `(flush-output-buffer ,stream-var))
@@ -575,7 +616,7 @@
   (if (eql byte #\Newline)
       (setf (fd-stream-char-pos stream) 0)
       (incf (fd-stream-char-pos stream)))
-  (setf (sap-ref-8 (buffer-sap obuf) (buffer-tail obuf))
+  (setf (sap-ref-8 (buffer-sap obuf) tail)
         (char-code byte)))
 
 (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"
@@ -583,7 +624,7 @@
                       nil
                       (:none (unsigned-byte 8))
                       (:full (unsigned-byte 8)))
-  (setf (sap-ref-8 (buffer-sap obuf) (buffer-tail obuf))
+  (setf (sap-ref-8 (buffer-sap obuf) tail)
         byte))
 
 (def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED"
@@ -591,7 +632,7 @@
                       nil
                       (:none (signed-byte 8))
                       (:full (signed-byte 8)))
-  (setf (signed-sap-ref-8 (buffer-sap obuf) (buffer-tail obuf))
+  (setf (signed-sap-ref-8 (buffer-sap obuf) tail)
         byte))
 
 (def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED"
@@ -599,7 +640,7 @@
                       nil
                       (:none (unsigned-byte 16))
                       (:full (unsigned-byte 16)))
-  (setf (sap-ref-16 (buffer-sap obuf) (buffer-tail obuf))
+  (setf (sap-ref-16 (buffer-sap obuf) tail)
         byte))
 
 (def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED"
@@ -607,7 +648,7 @@
                       nil
                       (:none (signed-byte 16))
                       (:full (signed-byte 16)))
-  (setf (signed-sap-ref-16 (buffer-sap obuf) (buffer-tail obuf))
+  (setf (signed-sap-ref-16 (buffer-sap obuf) tail)
         byte))
 
 (def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED"
@@ -615,7 +656,7 @@
                       nil
                       (:none (unsigned-byte 32))
                       (:full (unsigned-byte 32)))
-  (setf (sap-ref-32 (buffer-sap obuf) (buffer-tail obuf))
+  (setf (sap-ref-32 (buffer-sap obuf) tail)
         byte))
 
 (def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED"
@@ -623,7 +664,7 @@
                       nil
                       (:none (signed-byte 32))
                       (:full (signed-byte 32)))
-  (setf (signed-sap-ref-32 (buffer-sap obuf) (buffer-tail obuf))
+  (setf (signed-sap-ref-32 (buffer-sap obuf) tail)
         byte))
 
 #+#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or))
@@ -633,14 +674,14 @@
                         nil
                         (:none (unsigned-byte 64))
                         (:full (unsigned-byte 64)))
-    (setf (sap-ref-64 (buffer-sap obuf) (buffer-tail obuf))
+    (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) (buffer-tail obuf))
+    (setf (signed-sap-ref-64 (buffer-sap obuf) tail)
           byte)))
 
 ;;; the routine to use to output a string. If the stream is
@@ -682,20 +723,44 @@
           (setf (fd-stream-char-pos stream) (- end last-newline 1))
           (incf (fd-stream-char-pos stream) (- end start))))))
 
-(defvar *external-formats* ()
+(defstruct (external-format
+             (:constructor %make-external-format)
+             (:conc-name ef-)
+             (:predicate external-format-p)
+             (:copier nil))
+  ;; All the names that can refer to this external format.  The first
+  ;; one is the canonical name.
+  (names (missing-arg) :type list :read-only t)
+  (read-n-chars-fun (missing-arg) :type function :read-only t)
+  (read-char-fun (missing-arg) :type function :read-only t)
+  (write-n-bytes-fun (missing-arg) :type function :read-only t)
+  (write-char-none-buffered-fun (missing-arg) :type function :read-only t)
+  (write-char-line-buffered-fun (missing-arg) :type function :read-only t)
+  (write-char-full-buffered-fun (missing-arg) :type function :read-only t)
+  ;; Can be nil for fixed-width formats.
+  (resync-fun nil :type (or function null) :read-only t)
+  (bytes-for-char-fun (missing-arg) :type function :read-only t)
+  (read-c-string-fun (missing-arg) :type function :read-only t)
+  (write-c-string-fun (missing-arg) :type function :read-only t)
+  ;; We make these symbols so that a developer working on the octets
+  ;; code can easily redefine things and use the new function definition
+  ;; without redefining the external format as well.  The slots above
+  ;; are functions because a developer working with those slots would be
+  ;; redefining the external format anyway.
+  (octets-to-string-sym (missing-arg) :type symbol :read-only t)
+  (string-to-octets-sym (missing-arg) :type symbol :read-only t))
+
+(defvar *external-formats* (make-hash-table)
   #!+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.")
+  "Hashtable of all available external formats. The table maps from
+  external-format names to EXTERNAL-FORMAT structures.")
 
 (defun get-external-format (external-format)
-  (dolist (entry *external-formats*)
-    (when (member external-format (first entry))
-      (return entry))))
+  (gethash external-format *external-formats*))
 
-(defun get-external-format-function (external-format index)
-  (let ((entry (get-external-format external-format)))
-    (when entry (nth index entry))))
+(defun get-external-format-or-lose (external-format)
+  (or (get-external-format external-format)
+      (error "Undefined external-format ~A" external-format)))
 
 ;;; Find an output routine to use given the type and buffering. Return
 ;;; as multiple values the routine, the real type transfered, and the
@@ -705,15 +770,14 @@
     (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))
+          (values (ecase buffering
+                    (:none (ef-write-char-none-buffered-fun entry))
+                    (:line (ef-write-char-line-buffered-fun entry))
+                    (:full (ef-write-char-full-buffered-fun entry)))
                   'character
                   1
-                  (symbol-function (fourth entry))
-                  (first (first entry)))))))
+                  (ef-write-n-bytes-fun entry)
+                  (first (ef-names entry)))))))
   (dolist (entry *output-routines*)
     (when (and (subtypep type (first entry))
                (eq buffering (second entry))
@@ -737,14 +801,14 @@
                    (output-wrapper (stream (/ i 8) (:none) nil)
                      (loop for j from 0 below (/ i 8)
                            do (setf (sap-ref-8 (buffer-sap obuf)
-                                               (+ j (buffer-tail 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 (buffer-tail obuf)))
+                                               (+ j tail))
                                     (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
               `(unsigned-byte ,i)
               (/ i 8))))
@@ -758,14 +822,14 @@
                    (output-wrapper (stream (/ i 8) (:none) nil)
                      (loop for j from 0 below (/ i 8)
                            do (setf (sap-ref-8 (buffer-sap obuf)
-                                               (+ j (buffer-tail 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 (buffer-tail obuf)))
+                                               (+ j tail))
                                     (ldb (byte 8 (- i 8 (* j 8))) byte)))))))
               `(signed-byte ,i)
               (/ i 8)))))
@@ -785,10 +849,10 @@
 ;;; correct on win32.  However, none of the places that use it require
 ;;; further assurance than "may" versus "will definitely not".
 (defun sysread-may-block-p (stream)
-  #+win32
+  #!+win32
   ;; This answers T at EOF on win32, I think.
   (not (sb!win32:fd-listen (fd-stream-fd stream)))
-  #-win32
+  #!-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)
@@ -808,9 +872,9 @@
 ;;; 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))
+  (dx-let ((fd (fd-stream-fd stream))
+           (errno 0)
+           (count 0))
     (tagbody
        ;; Check for blocking input before touching the stream, as if
        ;; we happen to wait we are liable to be interrupted, and the
@@ -834,50 +898,61 @@
        ;; 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.
-       (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.
-         (let* ((ibuf (or (fd-stream-ibuf stream) (go :closed-flame)))
-                (sap (buffer-sap ibuf))
-                (length (buffer-length ibuf))
-                (head (buffer-head ibuf))
-                (tail (buffer-tail ibuf)))
-           (declare (index length head tail))
-           (unless (zerop head)
-             (cond ((eql head tail)
-                    ;; Buffer is empty, but not at yet reset -- make it so.
-                    (setf head 0
-                          tail 0)
-                    (reset-buffer ibuf))
-                   (t
-                    ;; Buffer has things in it, but they are not at the head
-                    ;; -- move them there.
-                    (let ((n (- tail head)))
-                      (system-area-ub8-copy sap head sap 0 n)
-                      (setf head 0
-                            (buffer-head ibuf) head
-                            tail n
-                            (buffer-tail ibuf) tail)))))
-
-           (setf (fd-stream-listen stream) nil)
-           (setf (values count errno)
-                 (sb!unix:unix-read fd (sap+ sap tail) (- length tail)))
-           (cond ((null count)
-                  #!+win32
-                  (go :read-error)
-                  #!-win32
-                  (if (eql errno sb!unix:ewouldblock)
-                      (go :wait-for-input)
-                      (go :read-error)))
-                 ((zerop count)
-                  (setf (fd-stream-listen stream) :eof)
-                  (/show0 "THROWing EOF-INPUT-CATCHER")
-                  (throw 'eof-input-catcher nil))
-                 (t
-                  ;; Success!
-                  (incf (buffer-tail ibuf) count))))))
+
+       ;; 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 sb!unix:unix-read))
+                (unless (zerop head)
+                  (cond ((eql head tail)
+                         ;; Buffer is empty, but not at yet reset -- make it so.
+                         (setf head 0
+                               tail 0)
+                         (reset-buffer ibuf))
+                        (t
+                         ;; Buffer has things in it, but they are not at the
+                         ;; head -- move them there.
+                         (let ((n (- tail head)))
+                           (system-area-ub8-copy sap head sap 0 n)
+                           (setf head 0
+                                 (buffer-head ibuf) head
+                                 tail n
+                                 (buffer-tail ibuf) tail)))))
+                (setf (fd-stream-listen stream) nil)
+                (setf (values count errno)
+                      (sb!unix:unix-read fd (sap+ sap tail) (- length tail)))
+                (cond ((null count)
+                       #!+win32
+                       (return :read-error)
+                       #!-win32
+                       (if (eql errno sb!unix:ewouldblock)
+                           (return :wait-for-input)
+                           (return :read-error)))
+                      ((zerop count)
+                       (setf (fd-stream-listen stream) :eof)
+                       (/show0 "THROWing EOF-INPUT-CATCHER")
+                       (throw 'eof-input-catcher nil))
+                      (t
+                       ;; Success! (Do not use INCF, for sake of other threads.)
+                       (setf (buffer-tail ibuf) (+ count tail))))))))))
     count))
 
 ;;; Make sure there are at least BYTES number of bytes in the input
@@ -1040,14 +1115,14 @@
 ;;; 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))
+    (let ((entry (get-external-format external-format)))
+      (when entry
         (return-from pick-input-routine
-          (values (symbol-function (third entry))
+          (values (ef-read-char-fun entry)
                   'character
                   1
-                  (symbol-function (second entry))
-                  (first (first entry)))))))
+                  (ef-read-n-chars-fun entry)
+                  (first (ef-names entry)))))))
   (dolist (entry *input-routines*)
     (when (and (subtypep type (first entry))
                (or (not (fourth entry))
@@ -1150,15 +1225,14 @@
             ))))
 
 (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)))))
+  (let ((entry (get-external-format (fd-stream-external-format stream))))
+    (when entry
+      (funcall (ef-resync-fun entry) stream))))
 
 (defun get-fd-stream-character-sizer (stream)
-  (dolist (entry *external-formats*)
-    (when (member (fd-stream-external-format stream) (first entry))
-      (return-from get-fd-stream-character-sizer (ninth entry)))))
+  (let ((entry (get-external-format (fd-stream-external-format stream))))
+    (when entry
+      (ef-bytes-for-char-fun entry))))
 
 (defun fd-stream-character-size (stream char)
   (let ((sizer (get-fd-stream-character-sizer stream)))
@@ -1171,17 +1245,18 @@
 
 (defun find-external-format (external-format)
   (when external-format
-    (find external-format *external-formats* :test #'member :key #'car)))
+    (get-external-format external-format)))
 
 (defun variable-width-external-format-p (ef-entry)
-  (when (eighth ef-entry) t))
+  (and ef-entry (not (null (ef-resync-fun ef-entry)))))
 
 (defun bytes-for-char-fun (ef-entry)
-  (if ef-entry (symbol-function (ninth ef-entry)) (constantly 1)))
+  (if ef-entry (ef-bytes-for-char-fun 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)
+                                  out-expr in-expr
+                                  octets-to-string-sym
+                                  string-to-octets-sym)
   (let* ((name (first external-format))
          (out-function (symbolicate "OUTPUT-BYTES/" name))
          (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" (string name)))
@@ -1201,7 +1276,7 @@
           (declare (type index start end))
           (synchronize-stream-output stream)
           (unless (<= 0 start end (length string))
-            (signal-bounding-indices-bad-error string start end))
+            (sequence-bounding-indices-bad-error string start end))
           (do ()
               ((= end start))
             (let ((obuf (fd-stream-obuf stream)))
@@ -1346,18 +1421,28 @@
                     (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*)))))
+        (let ((entry (%make-external-format
+                      :names ',external-format
+                      :read-n-chars-fun #',in-function
+                      :read-char-fun #',in-char-function
+                      :write-n-bytes-fun #',out-function
+                      ,@(mapcan #'(lambda (buffering)
+                                    (list (intern (format nil "WRITE-CHAR-~A-BUFFERED-FUN" buffering) :keyword)
+                                          `#',(intern (format nil format (string buffering)))))
+                                '(:none :line :full))
+                      :resync-fun nil
+                      :bytes-for-char-fun #',size-function
+                      :read-c-string-fun #',read-c-string-function
+                      :write-c-string-fun #',output-c-string-function
+                      :octets-to-string-sym ',octets-to-string-sym
+                      :string-to-octets-sym ',string-to-octets-sym)))
+          (dolist (ef ',external-format)
+            (setf (gethash ef *external-formats*) entry))))))
 
 (defmacro define-external-format/variable-width
     (external-format output-restart out-size-expr
-     out-expr in-size-expr in-expr)
+     out-expr in-size-expr in-expr
+     octets-to-string-sym string-to-octets-sym)
   (let* ((name (first external-format))
          (out-function (symbolicate "OUTPUT-BYTES/" name))
          (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" (string name)))
@@ -1378,7 +1463,7 @@
           (declare (type index start end))
           (synchronize-stream-output stream)
           (unless (<= 0 start end (length string))
-            (signal-bounding-indices-bad-error string start end))
+            (sequence-bounding-indices-bad-error string start end))
           (do ()
               ((= end start))
             (let ((obuf (fd-stream-obuf stream)))
@@ -1599,141 +1684,23 @@
                   ,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))))))))
+      (let ((entry (%make-external-format
+                    :names ',external-format
+                    :read-n-chars-fun #',in-function
+                    :read-char-fun #',in-char-function
+                    :write-n-bytes-fun #',out-function
+                    ,@(mapcan #'(lambda (buffering)
+                                  (list (intern (format nil "WRITE-CHAR-~A-BUFFERED-FUN" buffering) :keyword)
+                                        `#',(intern (format nil format (string buffering)))))
+                              '(:none :line :full))
+                    :resync-fun #',resync-function
+                    :bytes-for-char-fun #',size-function
+                    :read-c-string-fun #',read-c-string-function
+                    :write-c-string-fun #',output-c-string-function
+                    :octets-to-string-sym ',octets-to-string-sym
+                    :string-to-octets-sym ',string-to-octets-sym)))
+        (dolist (ef ',external-format)
+          (setf (gethash ef *external-formats*) entry))))))
 
 ;;;; utility functions (misc routines, etc)
 
@@ -1904,20 +1871,26 @@
                         input-type
                         output-type))))))
 
-;;; Handles the resource-release aspects of stream closing.
+;;; Handles the resource-release aspects of stream closing, and marks
+;;; it as closed.
 (defun release-fd-stream-resources (fd-stream)
   (handler-case
       (without-interrupts
+        ;; Drop handlers first.
+        (when (fd-stream-handler fd-stream)
+          (remove-fd-handler (fd-stream-handler fd-stream))
+          (setf (fd-stream-handler fd-stream) nil))
         ;; Disable interrupts so that a asynch unwind will not leave
         ;; us with a dangling finalizer (that would close the same
-        ;; --possibly reassigned-- FD again).
+        ;; --possibly reassigned-- FD again), or a stream with a closed
+        ;; FD that appears open.
         (sb!unix:unix-close (fd-stream-fd fd-stream))
+        (set-closed-flame fd-stream)
         (when (fboundp 'cancel-finalization)
           (cancel-finalization fd-stream)))
     ;; On error unwind from WITHOUT-INTERRUPTS.
     (serious-condition (e)
       (error e)))
-
   ;; Release all buffers. If this is undone, or interrupted,
   ;; we're still safe: buffers have finalizers of their own.
   (release-fd-stream-buffers fd-stream))
@@ -1986,70 +1959,89 @@
                                  (do-listen)))))))
        (do-listen)))
     (:unread
-     (setf (fd-stream-unread fd-stream) arg1)
+     ;; If the stream is bivalent, the user might follow an
+     ;; unread-char with a read-byte.  In this case, the bookkeeping
+     ;; is simpler if we adjust the buffer head by the number of code
+     ;; units in the character.
+     ;; FIXME: there has to be a proper way to check for bivalence,
+     ;; right?
+     (if (fd-stream-bivalent-p fd-stream)
+         (decf (buffer-head (fd-stream-ibuf fd-stream))
+               (fd-stream-character-size fd-stream arg1))
+         (setf (fd-stream-unread fd-stream) arg1))
      (setf (fd-stream-listen fd-stream) t))
     (:close
-     (cond (arg1                    ; We got us an abort on our hands.
-            (when (fd-stream-handler fd-stream)
-              (remove-fd-handler (fd-stream-handler fd-stream))
-              (setf (fd-stream-handler fd-stream) nil))
-            ;; We can't do anything unless we know what file were
-            ;; dealing with, and we don't want to do anything
-            ;; strange unless we were writing to the file.
-            (when (and (fd-stream-file fd-stream) (fd-stream-obuf fd-stream))
-              (if (fd-stream-original fd-stream)
-                  ;; If the original is EQ to file we are appending
-                  ;; and can just close the file without renaming.
-                  (unless (eq (fd-stream-original fd-stream)
-                              (fd-stream-file fd-stream))
-                    ;; We have a handle on the original, just revert.
+     ;; Drop input buffers
+     (setf (ansi-stream-in-index fd-stream) +ansi-stream-in-buffer-length+
+           (ansi-stream-cin-buffer fd-stream) nil
+           (ansi-stream-in-buffer fd-stream) nil)
+     (cond (arg1
+            ;; We got us an abort on our hands.
+            (let ((outputp (fd-stream-obuf fd-stream))
+                  (file (fd-stream-file fd-stream))
+                  (orig (fd-stream-original fd-stream)))
+              ;; This takes care of the important stuff -- everything
+              ;; rest is cleaning up the file-system, which we cannot
+              ;; do on some platforms as long as the file is open.
+              (release-fd-stream-resources fd-stream)
+              ;; We can't do anything unless we know what file were
+              ;; dealing with, and we don't want to do anything
+              ;; strange unless we were writing to the file.
+              (when (and outputp file)
+                (if orig
+                    ;; If the original is EQ to file we are appending to
+                    ;; and can just close the file without renaming.
+                    (unless (eq orig file)
+                      ;; We have a handle on the original, just revert.
+                      (multiple-value-bind (okay err)
+                          (sb!unix:unix-rename orig file)
+                        ;; FIXME: Why is this a SIMPLE-STREAM-ERROR, and the
+                        ;; others are SIMPLE-FILE-ERRORS? Surely they should
+                        ;; all be the same?
+                        (unless okay
+                          (error 'simple-stream-error
+                                 :format-control
+                                 "~@<Couldn't restore ~S to its original contents ~
+                                  from ~S while closing ~S: ~2I~_~A~:>"
+                                 :format-arguments
+                                 (list file orig fd-stream (strerror err))
+                                 :stream fd-stream))))
+                    ;; We can't restore the original, and aren't
+                    ;; appending, so nuke that puppy.
+                    ;;
+                    ;; FIXME: This is currently the fate of superseded
+                    ;; files, and according to the CLOSE spec this is
+                    ;; wrong. However, there seems to be no clean way to
+                    ;; do that that doesn't involve either copying the
+                    ;; data (bad if the :abort resulted from a full
+                    ;; disk), or renaming the old file temporarily
+                    ;; (probably bad because stream opening becomes more
+                    ;; racy).
                     (multiple-value-bind (okay err)
-                        (sb!unix:unix-rename (fd-stream-original fd-stream)
-                                             (fd-stream-file fd-stream))
+                        (sb!unix:unix-unlink file)
                       (unless okay
-                        (simple-stream-perror
-                         "couldn't restore ~S to its original contents"
-                         fd-stream
-                         err))))
-                  ;; We can't restore the original, and aren't
-                  ;; appending, so nuke that puppy.
-                  ;;
-                  ;; FIXME: This is currently the fate of superseded
-                  ;; files, and according to the CLOSE spec this is
-                  ;; wrong. However, there seems to be no clean way to
-                  ;; do that that doesn't involve either copying the
-                  ;; data (bad if the :abort resulted from a full
-                  ;; disk), or renaming the old file temporarily
-                  ;; (probably bad because stream opening becomes more
-                  ;; racy).
-                  (multiple-value-bind (okay err)
-                      (sb!unix:unix-unlink (fd-stream-file fd-stream))
-                    (unless okay
-                      (error 'simple-file-error
-                             :pathname (fd-stream-file fd-stream)
-                             :format-control
-                             "~@<couldn't remove ~S: ~2I~_~A~:>"
-                             :format-arguments (list (fd-stream-file fd-stream)
-                                                     (strerror err))))))))
+                        (error 'simple-file-error
+                               :pathname file
+                               :format-control
+                               "~@<Couldn't remove ~S while closing ~S: ~2I~_~A~:>"
+                               :format-arguments
+                               (list file fd-stream (strerror err)))))))))
            (t
             (finish-fd-stream-output fd-stream)
-            (when (and (fd-stream-original fd-stream)
-                       (fd-stream-delete-original fd-stream))
-              (multiple-value-bind (okay err)
-                  (sb!unix:unix-unlink (fd-stream-original fd-stream))
-                (unless okay
-                  (error 'simple-file-error
-                         :pathname (fd-stream-original fd-stream)
-                         :format-control
-                         "~@<couldn't delete ~S during close of ~S: ~
-                          ~2I~_~A~:>"
-                         :format-arguments
-                         (list (fd-stream-original fd-stream)
-                               fd-stream
-                               (strerror err))))))))
-     (release-fd-stream-resources fd-stream)
-     ;; Mark as closed. FIXME: Maybe this should be the first thing done?
-     (sb!impl::set-closed-flame fd-stream))
+            (let ((orig (fd-stream-original fd-stream)))
+              (when (and orig (fd-stream-delete-original fd-stream))
+                (multiple-value-bind (okay err) (sb!unix:unix-unlink orig)
+                  (unless okay
+                    (error 'simple-file-error
+                           :pathname orig
+                           :format-control
+                           "~@<couldn't delete ~S while closing ~S: ~2I~_~A~:>"
+                           :format-arguments
+                           (list orig fd-stream (strerror err)))))))
+            ;; In case of no-abort close, don't *really* close the
+            ;; stream until the last moment -- the cleaning up of the
+            ;; original can be done first.
+            (release-fd-stream-resources fd-stream))))
     (:clear-input
      (fd-stream-clear-input fd-stream))
     (:force-output
@@ -2250,6 +2242,8 @@
                                  :buffering buffering
                                  :dual-channel-p dual-channel-p
                                  :external-format external-format
+                                 :bivalent-p (eq element-type :default)
+                                 :char-size (external-format-char-size external-format)
                                  :timeout
                                  (if timeout
                                      (coerce timeout 'single-float)
@@ -2262,7 +2256,8 @@
                   (sb!unix:unix-close fd)
                   #!+sb-show
                   (format *terminal-io* "** closed file descriptor ~W **~%"
-                          fd))))
+                          fd))
+                :dont-save t))
     stream))
 
 ;;; Pick a name to use for the backup file for the :IF-EXISTS
@@ -2319,19 +2314,23 @@
 
   ;; Calculate useful stuff.
   (multiple-value-bind (input output mask)
-      (case direction
+      (ecase direction
         (:input  (values   t nil sb!unix:o_rdonly))
         (:output (values nil   t sb!unix:o_wronly))
         (:io     (values   t   t sb!unix:o_rdwr))
         (:probe  (values   t nil sb!unix:o_rdonly)))
     (declare (type index mask))
-    (let* ((pathname (merge-pathnames filename))
-           (namestring
-            (cond ((unix-namestring pathname input))
-                  ((and input (eq if-does-not-exist :create))
-                   (unix-namestring pathname nil))
-                  ((and (eq direction :io) (not if-does-not-exist-given))
-                   (unix-namestring pathname nil)))))
+    (let* (;; PATHNAME is the pathname we associate with the stream.
+           (pathname (merge-pathnames filename))
+           (physical (physicalize-pathname pathname))
+           (truename (probe-file physical))
+           ;; NAMESTRING is the native namestring we open the file with.
+           (namestring (cond (truename
+                              (native-namestring truename :as-file t))
+                             ((or (not input)
+                                  (and input (eq if-does-not-exist :create))
+                                  (and (eq direction :io) (not if-does-not-exist-given)))
+                              (native-namestring physical :as-file t)))))
       ;; Process if-exists argument if we are doing any output.
       (cond (output
              (unless if-exists-given
@@ -2396,7 +2395,7 @@
                           (when (and output (= (logand orig-mode #o170000)
                                                #o40000))
                             (error 'simple-file-error
-                                   :pathname namestring
+                                   :pathname pathname
                                    :format-control
                                    "can't open ~S for output: is a directory"
                                    :format-arguments (list namestring)))
@@ -2496,9 +2495,19 @@
   (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 ()
-  (setf *available-buffers* nil)
+(defun stream-reinit (&optional init-buffers-p)
+  (when init-buffers-p
+    (with-available-buffers-lock ()
+      (aver (not (boundp '*available-buffers*)))
+      (setf *available-buffers* nil)))
   (with-output-to-string (*error-output*)
     (setf *stdin*
           (make-fd-stream 0 :name "standard input" :input t :buffering :line
@@ -2539,7 +2548,8 @@
       (cond (new-name
              (setf (fd-stream-pathname stream) new-name)
              (setf (fd-stream-file stream)
-                   (unix-namestring new-name nil))
+                   (native-namestring (physicalize-pathname new-name)
+                                      :as-file t))
              t)
             (t
              (fd-stream-pathname stream)))))