0.9.2.36:

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

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index ea3e116..69660e8 100644 (file)
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -57,6 +57,11 @@
   (fd -1 :type fixnum)       
   ;; controls when the output buffer is flushed
   (buffering :full :type (member :full :line :none))
   (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)
   (char-pos nil :type (or index null))
   ;; T if input is waiting on FD. :EOF if we hit EOF.
   ;; character position (if known)
   (char-pos nil :type (or index null))
   ;; T if input is waiting on FD. :EOF if we hit EOF.

@@ -120,6 +125,35 @@
         :stream stream
          :code code))
 
         :stream stream
          :code code))
 

+;;; 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 ((sap (fd-stream-ibuf-sap stream))
+                                  (head (fd-stream-ibuf-head stream)))
+                              (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))))
+

 ;;; This is called by the server when we can write to the given file
 ;;; descriptor. Attempt to write the data again. If it worked, remove
 ;;; the data from the OUTPUT-LATER list. If it didn't work, something
 ;;; This is called by the server when we can write to the given file
 ;;; descriptor. Attempt to write the data again. If it worked, remove
 ;;; the data from the OUTPUT-LATER list. If it didn't work, something

@@ -215,15 +249,14 @@
                       size))
             (flush-output-buffer ,stream-var)))
       ,(unless (eq (car buffering) :none)
                       size))
             (flush-output-buffer ,stream-var)))
       ,(unless (eq (car buffering) :none)

-        `(when (> (fd-stream-ibuf-tail ,stream-var)
-                  (fd-stream-ibuf-head ,stream-var))
+        `(when (and (not (fd-stream-dual-channel-p ,stream-var))
+                    (> (fd-stream-ibuf-tail ,stream-var)
+                       (fd-stream-ibuf-head ,stream-var)))

             (file-position ,stream-var (file-position ,stream-var))))
       ,(if restart
             (file-position ,stream-var (file-position ,stream-var))))
       ,(if restart

-           
-           `(with-simple-restart (output-nothing
-                                  "~@<Skip output of this character.~@:>")
-             ,@body
-             (incf (fd-stream-obuf-tail ,stream-var) size))
+           `(catch 'output-nothing
+             ,@body
+             (incf (fd-stream-obuf-tail ,stream-var) size))

            `(progn
              ,@body
              (incf (fd-stream-obuf-tail ,stream-var) size)))
            `(progn
              ,@body
              (incf (fd-stream-obuf-tail ,stream-var) size)))

@@ -245,14 +278,14 @@
                       ,size))
             (flush-output-buffer ,stream-var)))
       ,(unless (eq (car buffering) :none)
                       ,size))
             (flush-output-buffer ,stream-var)))
       ,(unless (eq (car buffering) :none)

-        `(when (> (fd-stream-ibuf-tail ,stream-var)
-                  (fd-stream-ibuf-head ,stream-var))
+        `(when (and (not (fd-stream-dual-channel-p ,stream-var))
+                    (> (fd-stream-ibuf-tail ,stream-var)
+                       (fd-stream-ibuf-head ,stream-var)))

             (file-position ,stream-var (file-position ,stream-var))))
       ,(if restart
             (file-position ,stream-var (file-position ,stream-var))))
       ,(if restart

-           `(with-simple-restart (output-nothing
-                                  "~@<Skip output of this character.~@:>")
-             ,@body
-             (incf (fd-stream-obuf-tail ,stream-var) ,size))
+          `(catch 'output-nothing
+             ,@body
+             (incf (fd-stream-obuf-tail ,stream-var) ,size))

            `(progn
              ,@body
              (incf (fd-stream-obuf-tail ,stream-var) ,size)))
            `(progn
              ,@body
              (incf (fd-stream-obuf-tail ,stream-var) ,size)))

@@ -273,8 +306,7 @@
        (mapcar
            (lambda (buffering)
              (let ((function
        (mapcar
            (lambda (buffering)
              (let ((function

-                    (intern (let ((*print-case* :upcase))
-                              (format nil name-fmt (car buffering))))))
+                    (intern (format nil name-fmt (string (car buffering))))))

                `(progn
                   (defun ,function (stream byte)
                     (output-wrapper/variable-width (stream ,size ,buffering ,restart)
                `(progn
                   (defun ,function (stream byte)
                     (output-wrapper/variable-width (stream ,size ,buffering ,restart)

@@ -300,8 +332,7 @@
        (mapcar
            (lambda (buffering)
              (let ((function
        (mapcar
            (lambda (buffering)
              (let ((function

-                    (intern (let ((*print-case* :upcase))
-                              (format nil name-fmt (car buffering))))))
+                    (intern (format nil name-fmt (string (car buffering))))))

                `(progn
                   (defun ,function (stream byte)
                     (output-wrapper (stream ,size ,buffering ,restart)
                `(progn
                   (defun ,function (stream byte)
                     (output-wrapper (stream ,size ,buffering ,restart)

@@ -395,8 +426,9 @@
   (let ((start (or start 0))
        (end (or end (length (the (simple-array * (*)) thing)))))
     (declare (type index start end))
   (let ((start (or start 0))
        (end (or end (length (the (simple-array * (*)) thing)))))
     (declare (type index start end))

-    (when (> (fd-stream-ibuf-tail fd-stream)
-            (fd-stream-ibuf-head fd-stream))
+    (when (and (not (fd-stream-dual-channel-p fd-stream))
+              (> (fd-stream-ibuf-tail fd-stream)
+                 (fd-stream-ibuf-head fd-stream)))

       (file-position fd-stream (file-position fd-stream)))
     (let* ((len (fd-stream-obuf-length fd-stream))
           (tail (fd-stream-obuf-tail fd-stream))
       (file-position fd-stream (file-position fd-stream)))
     (let* ((len (fd-stream-obuf-length fd-stream))
           (tail (fd-stream-obuf-tail fd-stream))

@@ -408,38 +440,32 @@
            ((zerop bytes)) ; easy case
            ((<= bytes space)
             (if (system-area-pointer-p thing)
            ((zerop bytes)) ; easy case
            ((<= bytes space)
             (if (system-area-pointer-p thing)

-                (system-area-copy thing
-                                  (* start sb!vm:n-byte-bits)
-                                  (fd-stream-obuf-sap fd-stream)
-                                  (* tail sb!vm:n-byte-bits)
-                                  (* bytes sb!vm:n-byte-bits))
+                (system-area-ub8-copy thing start
+                                       (fd-stream-obuf-sap fd-stream)
+                                       tail
+                                       bytes)

                 ;; FIXME: There should be some type checking somewhere to
                 ;; verify that THING here is a vector, not just <not a SAP>.
                 ;; FIXME: There should be some type checking somewhere to
                 ;; verify that THING here is a vector, not just <not a SAP>.

-                (copy-to-system-area thing
-                                     (+ (* start sb!vm:n-byte-bits)
-                                        (* sb!vm:vector-data-offset
-                                           sb!vm:n-word-bits))
-                                     (fd-stream-obuf-sap fd-stream)
-                                     (* tail sb!vm:n-byte-bits)
-                                     (* bytes sb!vm:n-byte-bits)))
+                (copy-ub8-to-system-area thing start
+                                          (fd-stream-obuf-sap fd-stream)
+                                          tail
+                                          bytes))

             (setf (fd-stream-obuf-tail fd-stream) newtail))
            ((<= bytes len)
             (flush-output-buffer fd-stream)
             (if (system-area-pointer-p thing)
             (setf (fd-stream-obuf-tail fd-stream) newtail))
            ((<= bytes len)
             (flush-output-buffer fd-stream)
             (if (system-area-pointer-p thing)

-                (system-area-copy thing
-                                  (* start sb!vm:n-byte-bits)
-                                  (fd-stream-obuf-sap fd-stream)
-                                  0
-                                  (* bytes sb!vm:n-byte-bits))
+                (system-area-ub8-copy thing
+                                       start
+                                       (fd-stream-obuf-sap fd-stream)
+                                       0
+                                       bytes)

                 ;; FIXME: There should be some type checking somewhere to
                 ;; verify that THING here is a vector, not just <not a SAP>.
                 ;; FIXME: There should be some type checking somewhere to
                 ;; verify that THING here is a vector, not just <not a SAP>.

-                (copy-to-system-area thing
-                                     (+ (* start sb!vm:n-byte-bits)
-                                        (* sb!vm:vector-data-offset
-                                           sb!vm:n-word-bits))
-                                     (fd-stream-obuf-sap fd-stream)
-                                     0
-                                     (* bytes sb!vm:n-byte-bits)))
+                (copy-ub8-to-system-area thing
+                                          start
+                                          (fd-stream-obuf-sap fd-stream)
+                                          0
+                                          bytes))

             (setf (fd-stream-obuf-tail fd-stream) bytes))
            (t
             (flush-output-buffer fd-stream)
             (setf (fd-stream-obuf-tail fd-stream) bytes))
            (t
             (flush-output-buffer fd-stream)

@@ -471,15 +497,15 @@
                                           :end end))))
          (if (and (typep thing 'base-string)
                   (eq (fd-stream-external-format stream) :latin-1))
                                           :end end))))
          (if (and (typep thing 'base-string)
                   (eq (fd-stream-external-format stream) :latin-1))

-         (ecase (fd-stream-buffering stream)
-           (:full
-            (output-raw-bytes stream thing start end))
-           (:line
-            (output-raw-bytes stream thing start end)
-            (when last-newline
-              (flush-output-buffer stream)))
-           (:none
-            (frob-output stream thing start end nil)))
+              (ecase (fd-stream-buffering stream)
+                (:full
+                 (output-raw-bytes stream thing start end))
+                (:line
+                 (output-raw-bytes stream thing start end)
+                 (when last-newline
+                   (flush-output-buffer stream)))
+                (:none
+                 (frob-output stream thing start end nil)))

              (ecase (fd-stream-buffering stream)
                (:full (funcall (fd-stream-output-bytes stream)
                                stream thing nil start end))
              (ecase (fd-stream-buffering stream)
                (:full (funcall (fd-stream-output-bytes stream)
                                stream thing nil start end))

@@ -588,10 +614,10 @@
 ;;; per element.
 (defvar *input-routines* ())
 
 ;;; per element.
 (defvar *input-routines* ())
 

-;;; Fill the input buffer, and return the first character. Throw to
-;;; EOF-INPUT-CATCHER if the eof was reached. Drop into SYSTEM:SERVER
-;;; if necessary.
-(defun frob-input (stream)
+;;; Fill the input buffer, and return the number of bytes read. Throw
+;;; to EOF-INPUT-CATCHER if the eof was reached. Drop into
+;;; SYSTEM:SERVER if necessary.
+(defun refill-buffer/fd (stream)

   (let ((fd (fd-stream-fd stream))
        (ibuf-sap (fd-stream-ibuf-sap stream))
        (buflen (fd-stream-ibuf-length stream))
   (let ((fd (fd-stream-fd stream))
        (ibuf-sap (fd-stream-ibuf-sap stream))
        (buflen (fd-stream-ibuf-length stream))

@@ -606,28 +632,25 @@
             (setf (fd-stream-ibuf-tail stream) 0))
            (t
             (decf tail head)
             (setf (fd-stream-ibuf-tail stream) 0))
            (t
             (decf tail head)

-            (system-area-copy ibuf-sap (* head sb!vm:n-byte-bits)
-                              ibuf-sap 0 (* tail sb!vm:n-byte-bits))
+            (system-area-ub8-copy ibuf-sap head
+                                   ibuf-sap 0 tail)

             (setf head 0)
             (setf (fd-stream-ibuf-head stream) 0)
             (setf (fd-stream-ibuf-tail stream) tail))))
     (setf (fd-stream-listen stream) nil)
             (setf head 0)
             (setf (fd-stream-ibuf-head stream) 0)
             (setf (fd-stream-ibuf-tail stream) tail))))
     (setf (fd-stream-listen stream) nil)

-    (multiple-value-bind (count errno)
-       ;; FIXME: Judging from compiler warnings, this WITH-ALIEN form expands
-       ;; into something which uses the not-yet-defined type
-       ;;   (SB!ALIEN-INTERNALS:ALIEN (* (SB!ALIEN:STRUCT SB!UNIX:FD-SET))).
-       ;; This is probably inefficient and unsafe and generally bad, so
-       ;; try to find some way to make that type known before
-       ;; this is compiled.
-       (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set)))
-         (sb!unix:fd-zero read-fds)
-         (sb!unix:fd-set fd read-fds)
-         (sb!unix:unix-fast-select (1+ fd)
-                                   (sb!alien:addr read-fds)
-                                   nil
-                                   nil
-                                   0
-                                   0))
+    (sb!unix:with-restarted-syscall (count errno)
+      ;; FIXME: Judging from compiler warnings, this WITH-ALIEN form expands
+      ;; into something which uses the not-yet-defined type
+      ;;   (SB!ALIEN-INTERNALS:ALIEN (* (SB!ALIEN:STRUCT SB!UNIX:FD-SET))).
+      ;; This is probably inefficient and unsafe and generally bad, so
+      ;; try to find some way to make that type known before
+      ;; this is compiled.
+      (sb!alien:with-alien ((read-fds (sb!alien:struct sb!unix:fd-set)))
+        (sb!unix:fd-zero read-fds)
+        (sb!unix:fd-set fd read-fds)
+        (sb!unix:unix-fast-select (1+ fd)
+                                  (sb!alien:addr read-fds)
+                                  nil nil 0 0))

       (case count
        (1)
        (0
       (case count
        (1)
        (0

@@ -648,17 +671,18 @@
                   (unless (sb!sys:wait-until-fd-usable
                            fd :input (fd-stream-timeout stream))
                     (error 'io-timeout :stream stream :direction :read))
                   (unless (sb!sys:wait-until-fd-usable
                            fd :input (fd-stream-timeout stream))
                     (error 'io-timeout :stream stream :direction :read))

-                  (frob-input stream))
+                  (refill-buffer/fd stream))

                 (simple-stream-perror "couldn't read from ~S" stream errno)))
            ((zerop count)
             (setf (fd-stream-listen stream) :eof)
             (/show0 "THROWing EOF-INPUT-CATCHER")
             (throw 'eof-input-catcher nil))
            (t
                 (simple-stream-perror "couldn't read from ~S" stream errno)))
            ((zerop count)
             (setf (fd-stream-listen stream) :eof)
             (/show0 "THROWing EOF-INPUT-CATCHER")
             (throw 'eof-input-catcher nil))
            (t

-            (incf (fd-stream-ibuf-tail stream) count))))))
+            (incf (fd-stream-ibuf-tail stream) count)
+             count)))))

                        
 ;;; Make sure there are at least BYTES number of bytes in the input
                        
 ;;; Make sure there are at least BYTES number of bytes in the input

-;;; buffer. Keep calling FROB-INPUT until that condition is met.
+;;; buffer. Keep calling REFILL-BUFFER/FD until that condition is met.

 (defmacro input-at-least (stream bytes)
   (let ((stream-var (gensym))
        (bytes-var (gensym)))
 (defmacro input-at-least (stream bytes)
   (let ((stream-var (gensym))
        (bytes-var (gensym)))

@@ -669,10 +693,9 @@
                      (fd-stream-ibuf-head ,stream-var))
                   ,bytes-var)
           (return))
                      (fd-stream-ibuf-head ,stream-var))
                   ,bytes-var)
           (return))

-        (frob-input ,stream-var)))))
+        (refill-buffer/fd ,stream-var)))))

 
 

-(defmacro input-wrapper/variable-width ((stream bytes eof-error eof-value
-                                               resync-function)
+(defmacro input-wrapper/variable-width ((stream bytes eof-error eof-value)

                                        &body read-forms)
   (let ((stream-var (gensym))
        (retry-var (gensym))
                                        &body read-forms)
   (let ((stream-var (gensym))
        (retry-var (gensym))

@@ -684,47 +707,36 @@
               (fd-stream-unread ,stream-var)
             (setf (fd-stream-unread ,stream-var) nil)
             (setf (fd-stream-listen ,stream-var) nil))
               (fd-stream-unread ,stream-var)
             (setf (fd-stream-unread ,stream-var) nil)
             (setf (fd-stream-listen ,stream-var) nil))

-          (let ((,element-var nil))
+          (let ((,element-var nil)
+                (decode-break-reason nil))

             (do ((,retry-var t))
                 ((not ,retry-var))
             (do ((,retry-var t))
                 ((not ,retry-var))

-              (setq ,retry-var nil)
-              (restart-case
+              (unless

                   (catch 'eof-input-catcher
                   (catch 'eof-input-catcher

-                    (unless
-                        (block character-decode
-                          (input-at-least ,stream-var 1)
-                          (let* ((byte (sap-ref-8 (fd-stream-ibuf-sap
-                                                   ,stream-var)
-                                                  (fd-stream-ibuf-head
-                                                   ,stream-var))))
-                            (setq size ,bytes)
-                            (input-at-least ,stream-var size)
-                            (setq ,element-var (locally ,@read-forms))))
-                      (stream-decoding-error
-                       ,stream-var
-                       (if size
-                           (loop for i from 0 below size
-                                 collect (sap-ref-8 (fd-stream-ibuf-sap
+                    (setf decode-break-reason
+                          (block decode-break-reason
+                            (input-at-least ,stream-var 1)
+                            (let* ((byte (sap-ref-8 (fd-stream-ibuf-sap

                                                      ,stream-var)
                                                      ,stream-var)

-                                                    (+ (fd-stream-ibuf-head
-                                                        ,stream-var)
-                                                       i)))
-                           (list (sap-ref-8 (fd-stream-ibuf-sap
-                                             ,stream-var)
-                                            (fd-stream-ibuf-head
-                                             ,stream-var)))))))
-                (attempt-resync ()
-                  :report (lambda (stream)
-                            (format stream
-                                    "~@<Attempt to resync the stream at a ~
-                                     character boundary and continue.~@:>"))
-                  (,resync-function ,stream-var)
-                  (setq ,retry-var t))
-                (force-end-of-file ()
-                  :report (lambda (stream)
-                            (format stream
-                                    "~@<Force an end of file.~@:>"))
-                  nil)))
+                                                    (fd-stream-ibuf-head
+                                                     ,stream-var))))
+                              (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 (- (fd-stream-ibuf-tail ,stream-var)
+                                     (fd-stream-ibuf-head ,stream-var))))
+                  (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 (fd-stream-ibuf-head ,stream-var) size)
                    ,element-var)
             (cond (,element-var
                    (incf (fd-stream-ibuf-head ,stream-var) size)
                    ,element-var)

@@ -752,13 +764,11 @@
                    (eof-or-lose ,stream-var ,eof-error ,eof-value))))))))
 
 (defmacro def-input-routine/variable-width (name
                    (eof-or-lose ,stream-var ,eof-error ,eof-value))))))))
 
 (defmacro def-input-routine/variable-width (name

-                                           (type external-format size sap head
-                                                 resync-function)
+                                           (type external-format size sap head)

                                            &rest body)
   `(progn
      (defun ,name (stream eof-error eof-value)
                                            &rest body)
   `(progn
      (defun ,name (stream eof-error eof-value)

-       (input-wrapper/variable-width (stream ,size eof-error eof-value
-                                            ,resync-function)
+       (input-wrapper/variable-width (stream ,size eof-error eof-value)

         (let ((,sap (fd-stream-ibuf-sap stream))
               (,head (fd-stream-ibuf-head stream)))
           ,@body)))
         (let ((,sap (fd-stream-ibuf-sap stream))
               (,head (fd-stream-ibuf-head stream)))
           ,@body)))

@@ -880,10 +890,9 @@
   (declare (type index start end))
   (let* ((length (- end start))
         (string (make-string length)))
   (declare (type index start end))
   (let* ((length (- end start))
         (string (make-string length)))

-    (copy-from-system-area sap (* start sb!vm:n-byte-bits)
-                          string (* sb!vm:vector-data-offset
-                                    sb!vm:n-word-bits)
-                          (* length sb!vm:n-byte-bits))
+    (copy-ub8-from-system-area sap start
+                               string 0
+                               length)

     string))
 
 ;;; the N-BIN method for FD-STREAMs
     string))
 
 ;;; the N-BIN method for FD-STREAMs

@@ -932,7 +941,7 @@
             (= total-copied requested)
             (return total-copied))
            (;; If EOF, we're done in another way.
             (= total-copied requested)
             (return total-copied))
            (;; If EOF, we're done in another way.

-            (zerop (refill-fd-stream-buffer stream))
+             (null (catch 'eof-input-catcher (refill-buffer/fd stream)))

             (if eof-error-p
                 (error 'end-of-file :stream stream)
                 (return total-copied)))
             (if eof-error-p
                 (error 'end-of-file :stream stream)
                 (return total-copied)))

@@ -940,49 +949,28 @@
            ;; through into another pass of the loop.
            ))))
 
            ;; through into another pass of the loop.
            ))))
 

-;;; Try to refill the stream buffer. Return the number of bytes read.
-;;; (For EOF, the return value will be zero, otherwise positive.)
-(defun refill-fd-stream-buffer (stream)
-  ;; We don't have any logic to preserve leftover bytes in the buffer,
-  ;; so we should only be called when the buffer is empty.
-  ;; FIXME: can have three bytes in buffer because of UTF-8
-  (let ((new-head 0)
-        (sap (fd-stream-ibuf-sap stream)))
-    (do ((head (fd-stream-ibuf-head stream) (1+ head))
-         (tail (fd-stream-ibuf-tail stream)))
-        ((= head tail))
-      (setf (sap-ref-8 sap new-head) (sap-ref-8 sap head))
-      (incf new-head))
-    (multiple-value-bind (count err)
-        (sb!unix:unix-read (fd-stream-fd stream)
-                           (sap+ sap new-head)
-                           (- (fd-stream-ibuf-length stream) new-head))
-      (declare (type (or index null) count))
-      (when (null count)
-        (simple-stream-perror "couldn't read from ~S" stream err))
-      (setf (fd-stream-listen stream) nil
-            (fd-stream-ibuf-head stream) 0
-            (fd-stream-ibuf-tail stream) (+ count new-head))
-      count)))
+(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)))))

 
 

+;;; 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))
 (defmacro define-external-format (external-format size output-restart
                                   out-expr in-expr)
   (let* ((name (first external-format))

-         (out-function (intern (let ((*print-case* :upcase))
-                                 (format nil "OUTPUT-BYTES/~A" name))))
-         (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" name))
-         (in-function (intern (let ((*print-case* :upcase))
-                                (format nil "FD-STREAM-READ-N-CHARACTERS/~A"
-                                        name))))
-         (in-char-function (intern (let ((*print-case* :upcase))
-                                     (format nil "INPUT-CHAR/~A" name)))))
+         (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)))

     `(progn
       (defun ,out-function (stream string flush-p start end)
        (let ((start (or start 0))
              (end (or end (length string))))
          (declare (type index start end))
     `(progn
       (defun ,out-function (stream string flush-p start end)
        (let ((start (or start 0))
              (end (or end (length string))))
          (declare (type index start end))

-         (when (> (fd-stream-ibuf-tail stream)
-                  (fd-stream-ibuf-head stream))
+         (when (and (not (fd-stream-dual-channel-p stream))
+                    (> (fd-stream-ibuf-tail stream)
+                       (fd-stream-ibuf-head stream)))

            (file-position stream (file-position stream)))
          (when (< end start)
            (error ":END before :START!"))
            (file-position stream (file-position stream)))
          (when (< end start)
            (error ":END before :START!"))

@@ -994,12 +982,11 @@
                        (tail (fd-stream-obuf-tail stream)))
                       ((or (= start end) (< (- len tail) 4)) tail)
                     ,(if output-restart
                        (tail (fd-stream-obuf-tail stream)))
                       ((or (= start end) (< (- len tail) 4)) tail)
                     ,(if output-restart

-                         `(with-simple-restart (output-nothing
-                                                "~@<Skip output of this character.~@:>")
-                           (let* ((byte (aref string start))
-                                  (bits (char-code byte)))
-                             ,out-expr
-                             (incf tail ,size)))
+                        `(catch 'output-nothing
+                           (let* ((byte (aref string start))
+                                  (bits (char-code byte)))
+                             ,out-expr
+                             (incf tail ,size)))

                          `(let* ((byte (aref string start))
                                   (bits (char-code byte)))
                              ,out-expr
                          `(let* ((byte (aref string start))
                                   (bits (char-code byte)))
                              ,out-expr

@@ -1053,7 +1040,7 @@
                   (= total-copied requested)
                   (return total-copied))
                  ( ;; If EOF, we're done in another way.
                   (= total-copied requested)
                   (return total-copied))
                  ( ;; If EOF, we're done in another way.

-                  (zerop (refill-fd-stream-buffer stream))
+                   (null (catch 'eof-input-catcher (refill-buffer/fd stream)))

                   (if eof-error-p
                       (error 'end-of-file :stream stream)
                       (return total-copied)))
                   (if eof-error-p
                       (error 'end-of-file :stream stream)
                       (return total-copied)))

@@ -1066,8 +1053,7 @@
       (setf *external-formats*
        (cons '(,external-format ,in-function ,in-char-function ,out-function
               ,@(mapcar #'(lambda (buffering)
       (setf *external-formats*
        (cons '(,external-format ,in-function ,in-char-function ,out-function
               ,@(mapcar #'(lambda (buffering)

-                            (intern (let ((*print-case* :upcase))
-                                      (format nil format buffering))))
+                            (intern (format nil format (string buffering))))

                         '(:none :line :full)))
        *external-formats*)))))
 
                         '(:none :line :full)))
        *external-formats*)))))
 

@@ -1075,43 +1061,46 @@
     (external-format output-restart out-size-expr
      out-expr in-size-expr in-expr)
   (let* ((name (first external-format))
     (external-format output-restart out-size-expr
      out-expr in-size-expr in-expr)
   (let* ((name (first external-format))

-        (out-function (intern (let ((*print-case* :upcase))
-                                (format nil "OUTPUT-BYTES/~A" name))))
-        (format (format nil "OUTPUT-CHAR-~A-~~A-BUFFERED" name))
-        (in-function (intern (let ((*print-case* :upcase))
-                               (format nil "FD-STREAM-READ-N-CHARACTERS/~A"
-                                       name))))
-        (in-char-function (intern (let ((*print-case* :upcase))
-                                    (format nil "INPUT-CHAR/~A" name))))
-        (resync-function (intern (let ((*print-case* :upcase))
-                                   (format nil "RESYNC/~A" name)))))
+        (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)))

     `(progn
     `(progn

-      (defun ,out-function (fd-stream string flush-p start end)
+      (defun ,out-function (stream string flush-p start end)

        (let ((start (or start 0))
              (end (or end (length string))))
          (declare (type index start end))
        (let ((start (or start 0))
              (end (or end (length string))))
          (declare (type index start end))

-         (when (> (fd-stream-ibuf-tail fd-stream)
-                  (fd-stream-ibuf-head fd-stream))
-           (file-position fd-stream (file-position fd-stream)))
+         (when (and (not (fd-stream-dual-channel-p stream))
+                    (> (fd-stream-ibuf-tail stream)
+                       (fd-stream-ibuf-head stream)))
+           (file-position stream (file-position stream)))

          (when (< end start)
            (error ":END before :START!"))
          (do ()
              ((= end start))
          (when (< end start)
            (error ":END before :START!"))
          (do ()
              ((= end start))

-           (setf (fd-stream-obuf-tail fd-stream)
-                 (do* ((len (fd-stream-obuf-length fd-stream))
-                       (sap (fd-stream-obuf-sap fd-stream))
-                       (tail (fd-stream-obuf-tail fd-stream)))
+           (setf (fd-stream-obuf-tail stream)
+                 (do* ((len (fd-stream-obuf-length stream))
+                       (sap (fd-stream-obuf-sap stream))
+                       (tail (fd-stream-obuf-tail stream)))

                       ((or (= start end) (< (- len tail) 4)) tail)
                       ((or (= start end) (< (- len tail) 4)) tail)

-                   (let* ((byte (aref string start))
-                          (bits (char-code byte))
-                          (size ,out-size-expr))
-                     ,out-expr
-                     (incf tail size)
-                     (incf start))))
+                   ,(if output-restart
+                        `(catch 'output-nothing
+                           (let* ((byte (aref string start))
+                                  (bits (char-code byte))
+                                  (size ,out-size-expr))
+                             ,out-expr
+                             (incf tail size)))
+                        `(let* ((byte (aref string start))
+                                (bits (char-code byte))
+                                (size ,out-size-expr))
+                           ,out-expr
+                           (incf tail size)))
+                   (incf start)))

            (when (< start end)
            (when (< start end)

-             (flush-output-buffer fd-stream)))
+             (flush-output-buffer stream)))

          (when flush-p
          (when flush-p

-           (flush-output-buffer fd-stream))))
+           (flush-output-buffer stream))))

       (def-output-routines/variable-width (,format
                                           ,out-size-expr
                                            ,output-restart
       (def-output-routines/variable-width (,format
                                           ,out-size-expr
                                            ,output-restart

@@ -1140,55 +1129,44 @@
            (nil)
          (let* ((head (fd-stream-ibuf-head stream))
                 (tail (fd-stream-ibuf-tail stream))
            (nil)
          (let* ((head (fd-stream-ibuf-head stream))
                 (tail (fd-stream-ibuf-tail stream))

-                (sap (fd-stream-ibuf-sap stream)))
+                (sap (fd-stream-ibuf-sap stream))
+                (head-start head)
+                (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)))
            (declare (type index head tail))
            ;; Copy data from stream buffer into user's buffer.
            (do ((size nil nil))
                ((or (= tail head) (= requested total-copied)))

-             (restart-case
-                 (unless (block character-decode
-                           (let ((byte (sap-ref-8 sap head)))
-                             (setq size ,in-size-expr)
-                             (when (> size (- tail head))
-                               (return))
-                             (setf (aref buffer (+ start total-copied))
-                                   ,in-expr)
-                             (incf total-copied)
-                             (incf head size)))
-                   (setf (fd-stream-ibuf-head stream) head)
-                   (if (plusp total-copied)
-                       (return-from ,in-function total-copied)
-                       (stream-decoding-error
-                        stream
-                        (if size
-                            (loop for i from 0 below size
-                                  collect (sap-ref-8 (fd-stream-ibuf-sap
-                                                      stream)
-                                                     (+ (fd-stream-ibuf-head
-                                                         stream)
-                                                        i)))
-                            (list (sap-ref-8 (fd-stream-ibuf-sap stream)
-                                             (fd-stream-ibuf-head stream)))))))
-               (attempt-resync ()
-                 :report (lambda (stream)
-                           (format stream
-                                   "~@<Attempt to resync the stream at a ~
-                                    character boundary and continue.~@:>"))
-                 (,resync-function stream)
-                 (setf head (fd-stream-ibuf-head stream)))
-               (force-end-of-file ()
-                 :report (lambda (stream)
-                           (format stream "~@<Force an end of file.~@:>"))
+             (setf decode-break-reason
+                   (block decode-break-reason
+                     (let ((byte (sap-ref-8 sap head)))
+                       (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 (fd-stream-ibuf-head stream) head)
+             (when (and decode-break-reason
+                        (= head head-start))
+               (when (stream-decoding-error-and-handle
+                      stream decode-break-reason)

                  (if eof-error-p
                      (error 'end-of-file :stream stream)
                  (if eof-error-p
                      (error 'end-of-file :stream stream)

-                     (return-from ,in-function total-copied)))))
+                     (return-from ,in-function total-copied)))
+               (setf head (fd-stream-ibuf-head stream))
+               (setf tail (fd-stream-ibuf-tail stream)))
+             (when (plusp total-copied)
+               (return-from ,in-function total-copied)))

            (setf (fd-stream-ibuf-head stream) 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.
            (setf (fd-stream-ibuf-head stream) 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.

-                  (zerop (refill-fd-stream-buffer stream))
+                  (or (eq decode-break-reason 'eof)
+                       (null (catch 'eof-input-catcher 
+                               (refill-buffer/fd stream))))

                   (if eof-error-p
                       (error 'end-of-file :stream stream)
                       (return total-copied)))
                   (if eof-error-p
                       (error 'end-of-file :stream stream)
                       (return total-copied)))

@@ -1198,25 +1176,24 @@
       (def-input-routine/variable-width ,in-char-function (character
                                                           ,external-format
                                                           ,in-size-expr
       (def-input-routine/variable-width ,in-char-function (character
                                                           ,external-format
                                                           ,in-size-expr

-                                                          sap head
-                                                          ,resync-function)
+                                                          sap head)

        (let ((byte (sap-ref-8 sap head)))
          ,in-expr))
       (defun ,resync-function (stream)
         (loop (input-at-least stream 1)
               (incf (fd-stream-ibuf-head stream))
        (let ((byte (sap-ref-8 sap head)))
          ,in-expr))
       (defun ,resync-function (stream)
         (loop (input-at-least stream 1)
               (incf (fd-stream-ibuf-head stream))

-              (when (block character-decode
-                      (let* ((sap (fd-stream-ibuf-sap stream))
-                             (head (fd-stream-ibuf-head stream))
-                             (byte (sap-ref-8 sap head))
-                             (size ,in-size-expr))
-                        ,in-expr))
+              (unless (block decode-break-reason
+                       (let* ((sap (fd-stream-ibuf-sap stream))
+                              (head (fd-stream-ibuf-head stream))
+                              (byte (sap-ref-8 sap head))
+                              (size ,in-size-expr))
+                         ,in-expr)
+                       nil)

                 (return))))
       (setf *external-formats*
        (cons '(,external-format ,in-function ,in-char-function ,out-function
               ,@(mapcar #'(lambda (buffering)
                 (return))))
       (setf *external-formats*
        (cons '(,external-format ,in-function ,in-char-function ,out-function
               ,@(mapcar #'(lambda (buffering)

-                            (intern (let ((*print-case* :upcase))
-                                      (format nil format buffering))))
+                            (intern (format nil format (string buffering))))

                         '(:none :line :full))
               ,resync-function)
        *external-formats*)))))
                         '(:none :line :full))
               ,resync-function)
        *external-formats*)))))

@@ -1224,17 +1201,50 @@
 (define-external-format (:latin-1 :latin1 :iso-8859-1)
     1 t
   (if (>= bits 256)
 (define-external-format (:latin-1 :latin1 :iso-8859-1)
     1 t
   (if (>= bits 256)

-      (stream-encoding-error stream bits)
+      (stream-encoding-error-and-handle stream bits)

       (setf (sap-ref-8 sap tail) bits))
   (code-char byte))
 
       (setf (sap-ref-8 sap tail) bits))
   (code-char byte))
 

-(define-external-format (:ascii :us-ascii :ansi_x3.4-1968)
+(define-external-format (:ascii :us-ascii :ansi_x3.4-1968 
+                         :iso-646 :iso-646-us :|646|)

     1 t
   (if (>= bits 128)
     1 t
   (if (>= bits 128)

-      (stream-encoding-error stream bits)
+      (stream-encoding-error-and-handle stream bits)

       (setf (sap-ref-8 sap tail) bits))
   (code-char byte))
 
       (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)
+       (stream-encoding-error-and-handle 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)))
 #!+sb-unicode
 (let ((latin-9-table (let ((table (make-string 256)))
                        (do ((i 0 (1+ i)))

@@ -1261,10 +1271,10 @@
           (if (< bits 256)
               (if (= bits (char-code (aref latin-9-table bits)))
                   bits
           (if (< bits 256)
               (if (= bits (char-code (aref latin-9-table bits)))
                   bits

-                  (stream-encoding-error stream byte))
+                  (stream-encoding-error-and-handle stream byte))

               (if (= (aref latin-9-reverse-1 (logand bits 15)) bits)
                   (aref latin-9-reverse-2 (logand bits 15))
               (if (= (aref latin-9-reverse-1 (logand bits 15)) bits)
                   (aref latin-9-reverse-2 (logand bits 15))

-                  (stream-encoding-error stream byte))))
+                  (stream-encoding-error-and-handle stream byte))))

     (aref latin-9-table byte)))
 
 (define-external-format/variable-width (:utf-8 :utf8) nil
     (aref latin-9-table byte)))
 
 (define-external-format/variable-width (:utf-8 :utf8) nil

@@ -1285,7 +1295,7 @@
             (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)
             (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 character-decode))
+       ((< byte #xc2) (return-from decode-break-reason 1))

        ((< byte #xe0) 2)
        ((< byte #xf0) 3)
        (t 4))
        ((< byte #xe0) 2)
        ((< byte #xf0) 3)
        (t 4))

@@ -1293,13 +1303,13 @@
               (1 byte)
               (2 (let ((byte2 (sap-ref-8 sap (1+ head))))
                    (unless (<= #x80 byte2 #xbf)
               (1 byte)
               (2 (let ((byte2 (sap-ref-8 sap (1+ head))))
                    (unless (<= #x80 byte2 #xbf)

-                     (return-from character-decode))
+                     (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))
                    (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 character-decode))
+                     (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)))
                    (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)))

@@ -1307,7 +1317,7 @@
                    (unless (and (<= #x80 byte2 #xbf)
                                 (<= #x80 byte3 #xbf)
                                 (<= #x80 byte4 #xbf))
                    (unless (and (<= #x80 byte2 #xbf)
                                 (<= #x80 byte3 #xbf)
                                 (<= #x80 byte4 #xbf))

-                     (return-from character-decode))
+                     (return-from decode-break-reason 4))

                    (dpb byte (byte 3 18)
                         (dpb byte2 (byte 6 12)
                              (dpb byte3 (byte 6 6) byte4))))))))
                    (dpb byte (byte 3 18)
                         (dpb byte2 (byte 6 12)
                              (dpb byte3 (byte 6 6) byte4))))))))

@@ -1317,117 +1327,157 @@
 ;;; 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.
 ;;; 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 type input-p output-p buffer-p)
-  (let ((target-type (case type
-                      ((:default unsigned-byte)
-                       '(unsigned-byte 8))
-                      (signed-byte
-                       '(signed-byte 8))
-                      (t
-                       type)))
-       (input-type nil)
-       (output-type nil)
-       (input-size nil)
-       (output-size nil)
-       (character-stream-p (subtypep type 'character)))
-
-    (when (fd-stream-obuf-sap fd-stream)
+(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))
+
+    ;; drop buffers when direction changes
+    (when (and (fd-stream-obuf-sap fd-stream) (not output-p))

       (push (fd-stream-obuf-sap fd-stream) *available-buffers*)
       (setf (fd-stream-obuf-sap fd-stream) nil))
       (push (fd-stream-obuf-sap fd-stream) *available-buffers*)
       (setf (fd-stream-obuf-sap fd-stream) nil))

-    (when (fd-stream-ibuf-sap fd-stream)
+    (when (and (fd-stream-ibuf-sap fd-stream) (not input-p))

       (push (fd-stream-ibuf-sap fd-stream) *available-buffers*)
       (setf (fd-stream-ibuf-sap fd-stream) nil))
       (push (fd-stream-ibuf-sap fd-stream) *available-buffers*)
       (setf (fd-stream-ibuf-sap fd-stream) nil))

+    (when input-p
+      (setf (fd-stream-ibuf-sap fd-stream) (next-available-buffer))
+      (setf (fd-stream-ibuf-length fd-stream) bytes-per-buffer)
+      (setf (fd-stream-ibuf-tail fd-stream) 0))
+    (when output-p
+      (setf (fd-stream-obuf-sap fd-stream) (next-available-buffer))
+      (setf (fd-stream-obuf-length fd-stream) bytes-per-buffer)
+      (setf (fd-stream-obuf-tail fd-stream) 0)
+      (setf (fd-stream-char-pos fd-stream) 0))

 
     (when (and character-stream-p
 
     (when (and character-stream-p

-              (eq (fd-stream-external-format fd-stream) :default))
-      (setf (fd-stream-external-format fd-stream)
-           (intern (or (alien-funcall
-                        (extern-alien "nl_langinfo"
-                                      (function c-string int))
-                        sb!unix:codeset)
-                       "LATIN-1")
-                   "KEYWORD")))
-    (dolist (entry *external-formats*
-            (setf (fd-stream-external-format fd-stream) :latin-1))
-      (when (member (fd-stream-external-format fd-stream) (first entry))
-       (return)))
-
+              (eq external-format :default))
+      (/show0 "/getting default external format")
+      (setf external-format (default-external-format))
+      (/show0 "cold-printing defaulted external-format:")
+      #!+sb-show
+      (cold-print external-format)
+      (/show0 "matching to known aliases")
+      (dolist (entry *external-formats*
+                    (restart-case
+                         (error "Invalid external-format ~A" 
+                                external-format)
+                     (use-default ()
+                        :report "Set external format to LATIN-1"
+                        (setf external-format :latin-1))))
+        (/show0 "cold printing known aliases:")
+        #!+sb-show
+        (dolist (alias (first entry)) (cold-print alias))
+        (/show0 "done cold-printing known aliases")
+       (when (member external-format (first entry))
+          (/show0 "matched")
+         (return)))
+      (/show0 "/default external format ok"))
+    

     (when input-p
     (when input-p

-      (multiple-value-bind (routine type size read-n-characters
-                                    normalized-external-format)
-         (pick-input-routine target-type
-                              (fd-stream-external-format fd-stream))
-        (when normalized-external-format
-          (setf (fd-stream-external-format fd-stream)
-                normalized-external-format))
-       (unless routine
-         (error "could not find any input routine for ~S" target-type))
-       (setf (fd-stream-ibuf-sap fd-stream) (next-available-buffer))
-       (setf (fd-stream-ibuf-length fd-stream) bytes-per-buffer)
-       (setf (fd-stream-ibuf-tail fd-stream) 0)
-       (if character-stream-p
-           (setf (fd-stream-in fd-stream) routine
-                 (fd-stream-bin fd-stream) #'ill-bin)
-           (setf (fd-stream-in fd-stream) #'ill-in
-                 (fd-stream-bin fd-stream) routine))
-       (when (eql size 1)
-         (setf (fd-stream-n-bin fd-stream)
-                (if character-stream-p
-                    read-n-characters
-                    #'fd-stream-read-n-bytes))
-         (when (and buffer-p
-                    ;; We only create this buffer for streams of type
-                    ;; (unsigned-byte 8).  Because there's no buffer, the
-                    ;; other element-types will dispatch to the appropriate
-                    ;; input (output) routine in fast-read-byte.
-                    (or character-stream-p
-                        (equal target-type '(unsigned-byte 8)))
-                    (not output-p) ; temporary disable on :io streams
-                    #+(or)
-                    (or (eq type 'unsigned-byte)
-                        (eq type :default)))
-            (if character-stream-p
-                (setf (ansi-stream-cin-buffer fd-stream)
-                      (make-array +ansi-stream-in-buffer-length+
-                                  :element-type 'character))
-                (setf (ansi-stream-in-buffer fd-stream)
-                      (make-array +ansi-stream-in-buffer-length+
-                                  :element-type '(unsigned-byte 8))))))
-       (setf input-size size)
-       (setf input-type type)))
+      (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 output-p

-      (multiple-value-bind (routine type size output-bytes
-                                   normalized-external-format)
+      (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)
          (pick-output-routine target-type
                               (fd-stream-buffering fd-stream)

-                              (fd-stream-external-format fd-stream))
-       (when normalized-external-format
-         (setf (fd-stream-external-format fd-stream)
-               normalized-external-format))
-       (unless routine
+                              external-format))
+       (unless cout-routine

          (error "could not find any output routine for ~S buffered ~S"
                 (fd-stream-buffering fd-stream)
          (error "could not find any output routine for ~S buffered ~S"
                 (fd-stream-buffering fd-stream)

-                target-type))
-       (setf (fd-stream-obuf-sap fd-stream) (next-available-buffer))
-       (setf (fd-stream-obuf-length fd-stream) bytes-per-buffer)
-       (setf (fd-stream-obuf-tail fd-stream) 0)
-       (when character-stream-p
-         (setf (fd-stream-output-bytes fd-stream) output-bytes))
-       (if character-stream-p
-         (setf (fd-stream-out fd-stream) routine
-               (fd-stream-bout fd-stream) #'ill-bout)
-         (setf (fd-stream-out fd-stream)
-               (or (if (eql size 1)
-                         (pick-output-routine
-                          'base-char (fd-stream-buffering fd-stream)))
-                   #'ill-out)
-               (fd-stream-bout fd-stream) routine))
-       (setf (fd-stream-sout fd-stream)
-             (if (eql size 1) #'fd-sout #'ill-out))
-       (setf (fd-stream-char-pos fd-stream) 0)
-       (setf output-size size)
-       (setf output-type type)))
+                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)))
 
     (when (and input-size output-size
               (not (eq input-size output-size)))

@@ -1462,13 +1512,14 @@
                   (fd-stream-ibuf-tail fd-stream)))
         (fd-stream-listen fd-stream)
         (setf (fd-stream-listen fd-stream)
                   (fd-stream-ibuf-tail fd-stream)))
         (fd-stream-listen fd-stream)
         (setf (fd-stream-listen fd-stream)

-              (eql (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 fd-stream) read-fds)
-                     (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream))
-                                               (sb!alien:addr read-fds)
-                                               nil nil 0 0))
+              (eql (sb!unix:with-restarted-syscall ()
+                      (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 fd-stream) read-fds)
+                        (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream))
+                                                  (sb!alien:addr read-fds)
+                                                  nil nil 0 0)))

                    1))))
     (:unread
      (setf (fd-stream-unread fd-stream) arg1)
                    1))))
     (:unread
      (setf (fd-stream-unread fd-stream) arg1)

@@ -1549,18 +1600,16 @@
      (setf (fd-stream-ibuf-tail fd-stream) 0)
      (catch 'eof-input-catcher
        (loop
      (setf (fd-stream-ibuf-tail fd-stream) 0)
      (catch 'eof-input-catcher
        (loop

-       (let ((count (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 fd-stream) read-fds)
-                      (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream))
-                                                (sb!alien:addr read-fds)
-                                                nil
-                                                nil
-                                                0
-                                                0))))
+       (let ((count (sb!unix:with-restarted-syscall ()
+                       (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 fd-stream) read-fds)
+                         (sb!unix:unix-fast-select (1+ (fd-stream-fd fd-stream))
+                                                   (sb!alien:addr read-fds)
+                                                   nil nil 0 0)))))

          (cond ((eql count 1)
          (cond ((eql count 1)

-                (frob-input fd-stream)
+                (refill-buffer/fd fd-stream)

                 (setf (fd-stream-ibuf-head fd-stream) 0)
                 (setf (fd-stream-ibuf-tail fd-stream) 0))
                (t
                 (setf (fd-stream-ibuf-head fd-stream) 0)
                 (setf (fd-stream-ibuf-tail fd-stream) 0))
                (t

@@ -1574,6 +1623,8 @@
        (sb!sys:serve-all-events)))
     (:element-type
      (fd-stream-element-type fd-stream))
        (sb!sys:serve-all-events)))
     (: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)))))
     (:interactive-p
      (= 1 (the (member 0 1)
             (sb!unix:unix-isatty (fd-stream-fd fd-stream)))))

@@ -1602,6 +1653,12 @@
        (if (zerop mode)
           nil
           (truncate size (fd-stream-element-size fd-stream)))))
        (if (zerop mode)
           nil
           (truncate size (fd-stream-element-size fd-stream)))))

+    ;; FIXME: I doubt this is correct in the presence of Unicode,
+    ;; since fd-stream FILE-POSITION is measured in bytes. 
+    (:file-string-length
+     (etypecase arg1
+       (character 1)
+       (string (length arg1))))

     (:file-position
      (fd-stream-file-position fd-stream arg1))))
 
     (:file-position
      (fd-stream-file-position fd-stream arg1))))
 

@@ -1711,8 +1768,9 @@
                       delete-original
                       pathname
                       input-buffer-p
                       delete-original
                       pathname
                       input-buffer-p

+                      dual-channel-p

                       (name (if file
                       (name (if file

-                                (format nil "file ~S" file)
+                                (format nil "file ~A" file)

                                 (format nil "descriptor ~W" fd)))
                       auto-close)
   (declare (type index fd) (type (or index null) timeout)
                                 (format nil "descriptor ~W" fd)))
                       auto-close)
   (declare (type index fd) (type (or index null) timeout)

@@ -1728,9 +1786,11 @@
                                 :delete-original delete-original
                                 :pathname pathname
                                 :buffering buffering
                                 :delete-original delete-original
                                 :pathname pathname
                                 :buffering buffering

+                                :dual-channel-p dual-channel-p

                                 :external-format external-format
                                 :timeout timeout)))
                                 :external-format external-format
                                 :timeout timeout)))

-    (set-fd-stream-routines stream element-type input output input-buffer-p)
+    (set-fd-stream-routines stream element-type external-format
+                           input output input-buffer-p)

     (when (and auto-close (fboundp 'finalize))
       (finalize stream
                (lambda ()
     (when (and auto-close (fboundp 'finalize))
       (finalize stream
                (lambda ()

@@ -1850,7 +1910,7 @@
       (let ((original (case if-exists
                        ((:rename :rename-and-delete)
                         (pick-backup-name namestring))
       (let ((original (case if-exists
                        ((:rename :rename-and-delete)
                         (pick-backup-name namestring))

-                       ((:append)
+                       ((:append :overwrite)

                         ;; KLUDGE: Provent CLOSE from deleting
                         ;; appending streams when called with :ABORT T
                         namestring)))
                         ;; KLUDGE: Provent CLOSE from deleting
                         ;; appending streams when called with :ABORT T
                         namestring)))

@@ -1921,6 +1981,7 @@
                                      :original original
                                      :delete-original delete-original
                                      :pathname pathname
                                      :original original
                                      :delete-original delete-original
                                      :pathname pathname

+                                     :dual-channel-p nil

                                      :input-buffer-p t
                                      :auto-close t))
                     (:probe
                                      :input-buffer-p t
                                      :auto-close t))
                     (:probe

@@ -2012,29 +2073,3 @@
             t)
            (t
             (fd-stream-pathname stream)))))
             t)
            (t
             (fd-stream-pathname stream)))))

-\f
-;;;; international character support (which is trivial for our simple
-;;;; character sets)
-
-;;;; (Those who do Lisp only in English might not remember that ANSI
-;;;; requires these functions to be exported from package
-;;;; COMMON-LISP.)
-
-(defun file-string-length (stream object)
-  (declare (type (or string character) object) (type fd-stream stream))
-  #!+sb-doc
-  "Return the delta in STREAM's FILE-POSITION that would be caused by writing
-   OBJECT to STREAM. Non-trivial only in implementations that support
-   international character sets."
-  (declare (ignore stream))
-  (etypecase object
-    (character 1)
-    (string (length object))))
-
-(defun stream-external-format (stream)
-  (declare (type fd-stream stream))
-  #!+sb-doc
-  "Return the actual external format for fd-streams, otherwise :DEFAULT."
-  (if (typep stream 'fd-stream)
-      (fd-stream-external-format stream)
-      :default))