0.9.1.47

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

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 152acf2..60aeadb 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))

@@ -465,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))

@@ -582,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))

@@ -642,17 +674,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)))

@@ -663,10 +696,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))

@@ -678,47 +710,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)

@@ -746,13 +767,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)))

@@ -925,7 +944,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)))

@@ -933,49 +952,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!"))

@@ -987,12 +985,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

@@ -1046,7 +1043,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)))

@@ -1059,8 +1056,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*)))))
 

@@ -1068,43 +1064,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

@@ -1133,55 +1132,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)))

@@ -1191,25 +1179,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*)))))

@@ -1217,14 +1204,15 @@
 (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))
 

@@ -1255,7 +1243,7 @@
   (define-external-format (:ebcdic-us :ibm-037 :ibm037)
       1 t
     (if (>= bits 256)
   (define-external-format (:ebcdic-us :ibm-037 :ibm037)
       1 t
     (if (>= bits 256)

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

        (setf (sap-ref-8 sap tail) (aref reverse-table bits)))
     (aref table byte)))
     
        (setf (sap-ref-8 sap tail) (aref reverse-table bits)))
     (aref table byte)))
     

@@ -1286,10 +1274,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

@@ -1310,7 +1298,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))

@@ -1318,13 +1306,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)))

@@ -1332,7 +1320,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))))))))

@@ -1356,27 +1344,39 @@
        (output-size nil)
        (character-stream-p (subtypep type 'character)))
 
        (output-size nil)
        (character-stream-p (subtypep type 'character)))
 

-    (when (fd-stream-obuf-sap fd-stream)
+    ;; 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))
 
     (when (and character-stream-p
               (eq (fd-stream-external-format fd-stream) :default))
       (push (fd-stream-ibuf-sap fd-stream) *available-buffers*)
       (setf (fd-stream-ibuf-sap fd-stream) nil))
 
     (when (and character-stream-p
               (eq (fd-stream-external-format fd-stream) :default))

+      (/show0 "/getting default external format")

       (setf (fd-stream-external-format fd-stream)
       (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)))
-
+            (default-external-format))
+      (/show0 "cold-printing defaulted external-format:")
+      #!+sb-show
+      (cold-print (fd-stream-external-format fd-stream))
+      (/show0 "matching to known aliases")
+      (dolist (entry *external-formats*
+                    (restart-case
+                         (error "Invalid external-format ~A" 
+                                (fd-stream-external-format fd-stream))
+                     (use-default ()
+                        :report "Set external format to LATIN-1"
+                        (setf (fd-stream-external-format fd-stream) :latin-1))))
+        (/show0 "cold printing known aliases:")
+        #!+sb-show
+        (dolist (alias (first entry)) (cold-print alias))
+        (/show0 "done cold-printing known aliases")
+       (when (member (fd-stream-external-format fd-stream) (first entry))
+          (/show0 "matched")
+         (return)))
+      (/show0 "/default external format ok"))
+    

     (when input-p
       (multiple-value-bind (routine type size read-n-characters
                                     normalized-external-format)
     (when input-p
       (multiple-value-bind (routine type size read-n-characters
                                     normalized-external-format)

@@ -1387,9 +1387,6 @@
                 normalized-external-format))
        (unless routine
          (error "could not find any input routine for ~S" target-type))
                 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)
        (if character-stream-p
            (setf (fd-stream-in fd-stream) routine
                  (fd-stream-bin fd-stream) #'ill-bin)

@@ -1434,9 +1431,6 @@
          (error "could not find any output routine for ~S buffered ~S"
                 (fd-stream-buffering fd-stream)
                 target-type))
          (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
        (when character-stream-p
          (setf (fd-stream-output-bytes fd-stream) output-bytes))
        (if character-stream-p

@@ -1450,7 +1444,6 @@
                (fd-stream-bout fd-stream) routine))
        (setf (fd-stream-sout fd-stream)
              (if (eql size 1) #'fd-sout #'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)))
 
        (setf output-size size)
        (setf output-type type)))
 

@@ -1585,7 +1578,7 @@
                                                 0
                                                 0))))
          (cond ((eql count 1)
                                                 0
                                                 0))))
          (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

@@ -1599,6 +1592,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)))))

@@ -1627,6 +1622,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))))
 

@@ -1736,6 +1737,7 @@
                       delete-original
                       pathname
                       input-buffer-p
                       delete-original
                       pathname
                       input-buffer-p

+                      dual-channel-p

                       (name (if file
                                 (format nil "file ~S" file)
                                 (format nil "descriptor ~W" fd)))
                       (name (if file
                                 (format nil "file ~S" file)
                                 (format nil "descriptor ~W" fd)))

@@ -1753,8 +1755,18 @@
                                 :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)))

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

     (set-fd-stream-routines stream element-type input output input-buffer-p)
     (when (and auto-close (fboundp 'finalize))
       (finalize stream
     (set-fd-stream-routines stream element-type input output input-buffer-p)
     (when (and auto-close (fboundp 'finalize))
       (finalize stream

@@ -1875,7 +1887,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)))

@@ -1946,6 +1958,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

@@ -2037,29 +2050,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))