0.8.20.29:

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

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 528bd52..089b759 100644 (file)
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -31,16 +31,10 @@
       (pop *available-buffers*)
       (allocate-system-memory bytes-per-buffer)))
 \f
       (pop *available-buffers*)
       (allocate-system-memory bytes-per-buffer)))
 \f

-;;;; the FILE-STREAM structure
+;;;; the FD-STREAM structure

 
 

-(defstruct (file-stream
+(defstruct (fd-stream

            (:constructor %make-fd-stream)
            (:constructor %make-fd-stream)

-           ;; KLUDGE: in an ideal world, maybe we'd rewrite
-           ;; everything to use FILE-STREAM rather than simply
-           ;; providing this hack for compatibility with the old
-           ;; code.  However, CVS doesn't deal terribly well with
-           ;; file renaming, so for now we use this
-           ;; backward-compatibility feature.

            (:conc-name fd-stream-)
            (:predicate fd-stream-p)
            (:include ansi-stream
            (:conc-name fd-stream-)
            (:predicate fd-stream-p)
            (:include ansi-stream

@@ -89,7 +83,7 @@
   (pathname nil :type (or pathname null))
   (external-format :default)
   (output-bytes #'ill-out :type function))
   (pathname nil :type (or pathname null))
   (external-format :default)
   (output-bytes #'ill-out :type function))

-(def!method print-object ((fd-stream file-stream) stream)
+(def!method print-object ((fd-stream fd-stream) stream)

   (declare (type stream stream))
   (print-unreadable-object (fd-stream stream :type t :identity t)
     (format stream "for ~S" (fd-stream-name fd-stream))))
   (declare (type stream stream))
   (print-unreadable-object (fd-stream stream :type t :identity t)
     (format stream "for ~S" (fd-stream-name fd-stream))))

@@ -115,6 +109,17 @@
         :format-arguments
         (list note-format (list pathname) (strerror errno))))
 
         :format-arguments
         (list note-format (list pathname) (strerror errno))))
 

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

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

@@ -171,7 +176,7 @@
 ;;; writes. If so, just queue this one. Otherwise, try to write it. If
 ;;; this would block, queue it.
 (defun frob-output (stream base start end reuse-sap)
 ;;; writes. If so, just queue this one. Otherwise, try to write it. If
 ;;; this would block, queue it.
 (defun frob-output (stream base start end reuse-sap)

-  (declare (type file-stream stream)
+  (declare (type fd-stream stream)

           (type (or system-area-pointer (simple-array * (*))) base)
           (type index start end))
   (if (not (null (fd-stream-output-later stream))) ; something buffered.
           (type (or system-area-pointer (simple-array * (*))) base)
           (type index start end))
   (if (not (null (fd-stream-output-later stream))) ; something buffered.

@@ -199,7 +204,7 @@
       (frob-output stream (fd-stream-obuf-sap stream) 0 length t)
       (setf (fd-stream-obuf-tail stream) 0))))
 
       (frob-output stream (fd-stream-obuf-sap stream) 0 length t)
       (setf (fd-stream-obuf-tail stream) 0))))
 

-(defmacro output-wrapper/variable-width ((stream size buffering)
+(defmacro output-wrapper/variable-width ((stream size buffering restart)

                                         &body body)
   (let ((stream-var (gensym)))
     `(let ((,stream-var ,stream)
                                         &body body)
   (let ((stream-var (gensym)))
     `(let ((,stream-var ,stream)

@@ -213,9 +218,15 @@
         `(when (> (fd-stream-ibuf-tail ,stream-var)
                   (fd-stream-ibuf-head ,stream-var))
             (file-position ,stream-var (file-position ,stream-var))))
         `(when (> (fd-stream-ibuf-tail ,stream-var)
                   (fd-stream-ibuf-head ,stream-var))
             (file-position ,stream-var (file-position ,stream-var))))

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

       ,(ecase (car buffering)
         (:none
          `(flush-output-buffer ,stream-var))
       ,(ecase (car buffering)
         (:none
          `(flush-output-buffer ,stream-var))

@@ -225,7 +236,7 @@
         (:full))
     (values))))
 
         (:full))
     (values))))
 

-(defmacro output-wrapper ((stream size buffering) &body body)
+(defmacro output-wrapper ((stream size buffering restart) &body body)

   (let ((stream-var (gensym)))
     `(let ((,stream-var ,stream))
       ,(unless (eq (car buffering) :none)
   (let ((stream-var (gensym)))
     `(let ((,stream-var ,stream))
       ,(unless (eq (car buffering) :none)

@@ -237,9 +248,14 @@
         `(when (> (fd-stream-ibuf-tail ,stream-var)
                   (fd-stream-ibuf-head ,stream-var))
             (file-position ,stream-var (file-position ,stream-var))))
         `(when (> (fd-stream-ibuf-tail ,stream-var)
                   (fd-stream-ibuf-head ,stream-var))
             (file-position ,stream-var (file-position ,stream-var))))

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

       ,(ecase (car buffering)
         (:none
          `(flush-output-buffer ,stream-var))
       ,(ecase (car buffering)
         (:none
          `(flush-output-buffer ,stream-var))

@@ -249,9 +265,9 @@
         (:full))
     (values))))
 
         (:full))
     (values))))
 

-(defmacro def-output-routines/variable-width ((name-fmt size external-format
-                                                       &rest bufferings)
-                                             &body body)
+(defmacro def-output-routines/variable-width
+    ((name-fmt size restart external-format &rest bufferings)
+     &body body)

   (declare (optimize (speed 1)))
   (cons 'progn
        (mapcar
   (declare (optimize (speed 1)))
   (cons 'progn
        (mapcar

@@ -261,7 +277,7 @@
                               (format nil name-fmt (car buffering))))))
                `(progn
                   (defun ,function (stream byte)
                               (format nil name-fmt (car buffering))))))
                `(progn
                   (defun ,function (stream byte)

-                    (output-wrapper/variable-width (stream ,size ,buffering)
+                    (output-wrapper/variable-width (stream ,size ,buffering ,restart)

                       ,@body))
                   (setf *output-routines*
                         (nconc *output-routines*
                       ,@body))
                   (setf *output-routines*
                         (nconc *output-routines*

@@ -277,7 +293,8 @@
 
 ;;; Define output routines that output numbers SIZE bytes long for the
 ;;; given bufferings. Use BODY to do the actual output.
 
 ;;; Define output routines that output numbers SIZE bytes long for the
 ;;; given bufferings. Use BODY to do the actual output.

-(defmacro def-output-routines ((name-fmt size &rest bufferings) &body body)
+(defmacro def-output-routines ((name-fmt size restart &rest bufferings)
+                               &body body)

   (declare (optimize (speed 1)))
   (cons 'progn
        (mapcar
   (declare (optimize (speed 1)))
   (cons 'progn
        (mapcar

@@ -287,7 +304,7 @@
                               (format nil name-fmt (car buffering))))))
                `(progn
                   (defun ,function (stream byte)
                               (format nil name-fmt (car buffering))))))
                `(progn
                   (defun ,function (stream byte)

-                    (output-wrapper (stream ,size ,buffering)
+                    (output-wrapper (stream ,size ,buffering ,restart)

                       ,@body))
                   (setf *output-routines*
                         (nconc *output-routines*
                       ,@body))
                   (setf *output-routines*
                         (nconc *output-routines*

@@ -301,8 +318,10 @@
                                   (cdr buffering)))))))
            bufferings)))
 
                                   (cdr buffering)))))))
            bufferings)))
 

+;;; FIXME: is this used anywhere any more?

 (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
                      1
 (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
                      1

+                      t

                      (:none character)
                      (:line character)
                      (:full character))
                      (:none character)
                      (:line character)
                      (:full character))

@@ -314,6 +333,7 @@
 
 (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"
                      1
 
 (def-output-routines ("OUTPUT-UNSIGNED-BYTE-~A-BUFFERED"
                      1

+                      nil

                      (:none (unsigned-byte 8))
                      (:full (unsigned-byte 8)))
   (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
                      (:none (unsigned-byte 8))
                      (:full (unsigned-byte 8)))
   (setf (sap-ref-8 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))

@@ -321,6 +341,7 @@
 
 (def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED"
                      1
 
 (def-output-routines ("OUTPUT-SIGNED-BYTE-~A-BUFFERED"
                      1

+                      nil

                      (:none (signed-byte 8))
                      (:full (signed-byte 8)))
   (setf (signed-sap-ref-8 (fd-stream-obuf-sap stream)
                      (:none (signed-byte 8))
                      (:full (signed-byte 8)))
   (setf (signed-sap-ref-8 (fd-stream-obuf-sap stream)

@@ -329,6 +350,7 @@
 
 (def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED"
                      2
 
 (def-output-routines ("OUTPUT-UNSIGNED-SHORT-~A-BUFFERED"
                      2

+                      nil

                      (:none (unsigned-byte 16))
                      (:full (unsigned-byte 16)))
   (setf (sap-ref-16 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
                      (:none (unsigned-byte 16))
                      (:full (unsigned-byte 16)))
   (setf (sap-ref-16 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))

@@ -336,6 +358,7 @@
 
 (def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED"
                      2
 
 (def-output-routines ("OUTPUT-SIGNED-SHORT-~A-BUFFERED"
                      2

+                      nil

                      (:none (signed-byte 16))
                      (:full (signed-byte 16)))
   (setf (signed-sap-ref-16 (fd-stream-obuf-sap stream)
                      (:none (signed-byte 16))
                      (:full (signed-byte 16)))
   (setf (signed-sap-ref-16 (fd-stream-obuf-sap stream)

@@ -344,6 +367,7 @@
 
 (def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED"
                      4
 
 (def-output-routines ("OUTPUT-UNSIGNED-LONG-~A-BUFFERED"
                      4

+                      nil

                      (:none (unsigned-byte 32))
                      (:full (unsigned-byte 32)))
   (setf (sap-ref-32 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
                      (:none (unsigned-byte 32))
                      (:full (unsigned-byte 32)))
   (setf (sap-ref-32 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))

@@ -351,6 +375,7 @@
 
 (def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED"
                      4
 
 (def-output-routines ("OUTPUT-SIGNED-LONG-~A-BUFFERED"
                      4

+                      nil

                      (:none (signed-byte 32))
                      (:full (signed-byte 32)))
   (setf (signed-sap-ref-32 (fd-stream-obuf-sap stream)
                      (:none (signed-byte 32))
                      (:full (signed-byte 32)))
   (setf (signed-sap-ref-32 (fd-stream-obuf-sap stream)

@@ -516,7 +541,7 @@
              (ecase buffering
                (:none
                 (lambda (stream byte)
              (ecase buffering
                (:none
                 (lambda (stream byte)

-                  (output-wrapper (stream (/ i 8) (:none))
+                  (output-wrapper (stream (/ i 8) (:none) nil)

                     (loop for j from 0 below (/ i 8)
                           do (setf (sap-ref-8 
                                     (fd-stream-obuf-sap stream)
                     (loop for j from 0 below (/ i 8)
                           do (setf (sap-ref-8 
                                     (fd-stream-obuf-sap stream)

@@ -524,7 +549,7 @@
                                    (ldb (byte 8 (- i 8 (* j 8))) byte))))))
                (:full
                 (lambda (stream byte)
                                    (ldb (byte 8 (- i 8 (* j 8))) byte))))))
                (:full
                 (lambda (stream byte)

-                  (output-wrapper (stream (/ i 8) (:full))
+                  (output-wrapper (stream (/ i 8) (:full) nil)

                     (loop for j from 0 below (/ i 8)
                           do (setf (sap-ref-8 
                                     (fd-stream-obuf-sap stream)
                     (loop for j from 0 below (/ i 8)
                           do (setf (sap-ref-8 
                                     (fd-stream-obuf-sap stream)

@@ -539,7 +564,7 @@
              (ecase buffering
                (:none
                 (lambda (stream byte)
              (ecase buffering
                (:none
                 (lambda (stream byte)

-                  (output-wrapper (stream (/ i 8) (:none))
+                  (output-wrapper (stream (/ i 8) (:none) nil)

                     (loop for j from 0 below (/ i 8)
                           do (setf (sap-ref-8 
                                     (fd-stream-obuf-sap stream)
                     (loop for j from 0 below (/ i 8)
                           do (setf (sap-ref-8 
                                     (fd-stream-obuf-sap stream)

@@ -547,7 +572,7 @@
                                    (ldb (byte 8 (- i 8 (* j 8))) byte))))))
                (:full
                 (lambda (stream byte)
                                    (ldb (byte 8 (- i 8 (* j 8))) byte))))))
                (:full
                 (lambda (stream byte)

-                  (output-wrapper (stream (/ i 8) (:full))
+                  (output-wrapper (stream (/ i 8) (:full) nil)

                     (loop for j from 0 below (/ i 8)
                           do (setf (sap-ref-8 
                                     (fd-stream-obuf-sap stream)
                     (loop for j from 0 below (/ i 8)
                           do (setf (sap-ref-8 
                                     (fd-stream-obuf-sap stream)

@@ -646,9 +671,11 @@
           (return))
         (frob-input ,stream-var)))))
 
           (return))
         (frob-input ,stream-var)))))
 

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

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

+       (retry-var (gensym))

        (element-var (gensym)))
     `(let ((,stream-var ,stream)
           (size nil))
        (element-var (gensym)))
     `(let ((,stream-var ,stream)
           (size nil))

@@ -657,14 +684,47 @@
               (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
-                 (catch 'eof-input-catcher
-                   (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)
-                     (locally ,@read-forms)))))
+          (let ((,element-var nil))
+            (do ((,retry-var t))
+                ((not ,retry-var))
+              (setq ,retry-var nil)
+              (restart-case
+                  (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
+                                                     ,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)))

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

@@ -692,11 +752,13 @@
                    (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)
+                                           (type external-format size sap head
+                                                 resync-function)

                                            &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)
+       (input-wrapper/variable-width (stream ,size eof-error eof-value
+                                            ,resync-function)

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

@@ -831,7 +893,7 @@
 ;;; isn't too problematical.
 (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p
                               &aux (total-copied 0))
 ;;; isn't too problematical.
 (defun fd-stream-read-n-bytes (stream buffer start requested eof-error-p
                               &aux (total-copied 0))

-  (declare (type file-stream stream))
+  (declare (type fd-stream stream))

   (declare (type index start requested total-copied))
   (let ((unread (fd-stream-unread stream)))
     (when unread
   (declare (type index start requested total-copied))
   (let ((unread (fd-stream-unread stream)))
     (when unread

@@ -899,11 +961,12 @@
       (when (null count)
         (simple-stream-perror "couldn't read from ~S" stream err))
       (setf (fd-stream-listen stream) nil
       (when (null count)
         (simple-stream-perror "couldn't read from ~S" stream err))
       (setf (fd-stream-listen stream) nil

-            (fd-stream-ibuf-head stream) new-head
+            (fd-stream-ibuf-head stream) 0

             (fd-stream-ibuf-tail stream) (+ count new-head))
       count)))
 
             (fd-stream-ibuf-tail stream) (+ count new-head))
       count)))
 

-(defmacro define-external-format (external-format size out-expr in-expr)
+(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))))
   (let* ((name (first external-format))
          (out-function (intern (let ((*print-case* :upcase))
                                  (format nil "OUTPUT-BYTES/~A" name))))

@@ -914,33 +977,41 @@
          (in-char-function (intern (let ((*print-case* :upcase))
                                      (format nil "INPUT-CHAR/~A" name)))))
     `(progn
          (in-char-function (intern (let ((*print-case* :upcase))
                                      (format nil "INPUT-CHAR/~A" name)))))
     `(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 (> (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)))
-                     ,out-expr
-                     (incf tail ,size)
-                     (incf start))))
+                    ,(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)))
+                         `(let* ((byte (aref string start))
+                                  (bits (char-code byte)))
+                             ,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 (,format
                            ,size
       (def-output-routines (,format
                            ,size

+                            ,output-restart

                            (:none character)
                            (:line character)
                            (:full character))
                            (:none character)
                            (:line character)
                            (:full character))

@@ -953,7 +1024,7 @@
          ,out-expr))
       (defun ,in-function (stream buffer start requested eof-error-p
                           &aux (total-copied 0))
          ,out-expr))
       (defun ,in-function (stream buffer start requested eof-error-p
                           &aux (total-copied 0))

-       (declare (type file-stream stream))
+       (declare (type fd-stream stream))

        (declare (type index start requested total-copied))
        (let ((unread (fd-stream-unread stream)))
          (when unread
        (declare (type index start requested total-copied))
        (let ((unread (fd-stream-unread stream)))
          (when unread

@@ -1000,8 +1071,9 @@
                         '(:none :line :full)))
        *external-formats*)))))
 
                         '(:none :line :full)))
        *external-formats*)))))
 

-(defmacro define-external-format/variable-width (external-format out-size-expr
-                                                out-expr in-size-expr in-expr)
+(defmacro define-external-format/variable-width
+    (external-format output-restart out-size-expr
+     out-expr in-size-expr in-expr)

   (let* ((name (first external-format))
         (out-function (intern (let ((*print-case* :upcase))
                                 (format nil "OUTPUT-BYTES/~A" name))))
   (let* ((name (first external-format))
         (out-function (intern (let ((*print-case* :upcase))
                                 (format nil "OUTPUT-BYTES/~A" name))))

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

     `(progn
       (defun ,out-function (fd-stream string flush-p start end)
        (let ((start (or start 0))
     `(progn
       (defun ,out-function (fd-stream string flush-p start end)
        (let ((start (or start 0))

@@ -1040,6 +1114,7 @@
            (flush-output-buffer fd-stream))))
       (def-output-routines/variable-width (,format
                                           ,out-size-expr
            (flush-output-buffer fd-stream))))
       (def-output-routines/variable-width (,format
                                           ,out-size-expr

+                                           ,output-restart

                                           ,external-format
                                           (:none character)
                                           (:line character)
                                           ,external-format
                                           (:none character)
                                           (:line character)

@@ -1053,7 +1128,7 @@
          ,out-expr))
       (defun ,in-function (stream buffer start requested eof-error-p
                           &aux (total-copied 0))
          ,out-expr))
       (defun ,in-function (stream buffer start requested eof-error-p
                           &aux (total-copied 0))

-       (declare (type file-stream stream))
+       (declare (type fd-stream stream))

        (declare (type index start requested total-copied))
        (let ((unread (fd-stream-unread stream)))
          (when unread
        (declare (type index start requested total-copied))
        (let ((unread (fd-stream-unread stream)))
          (when unread

@@ -1068,15 +1143,45 @@
                 (sap (fd-stream-ibuf-sap stream)))
            (declare (type index head tail))
            ;; Copy data from stream buffer into user's buffer.
                 (sap (fd-stream-ibuf-sap stream)))
            (declare (type index head tail))
            ;; Copy data from stream buffer into user's buffer.

-           (do ()
+           (do ((size nil nil))

                ((or (= tail head) (= requested total-copied)))
                ((or (= tail head) (= requested total-copied)))

-             (let* ((byte (sap-ref-8 sap head))
-                    (size ,in-size-expr))
-               (when (> size (- tail head))
-                 (return))
-               (setf (aref buffer (+ start total-copied)) ,in-expr)
-               (incf total-copied)
-               (incf head size)))
+             (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.~@:>"))
+                 (if eof-error-p
+                     (error 'end-of-file :stream stream)
+                     (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.
            (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.

@@ -1093,26 +1198,108 @@
       (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)
+                                                          sap head
+                                                          ,resync-function)

        (let ((byte (sap-ref-8 sap head)))
          ,in-expr))
        (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))
+                (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))))
       (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))))

-                        '(:none :line :full)))
+                        '(:none :line :full))
+              ,resync-function)

        *external-formats*)))))
 
        *external-formats*)))))
 

-(define-external-format (:latin-1 :latin1 :iso-8859-1
-                         ;; FIXME: shouldn't ASCII-like things have an
-                         ;; extra typecheck for 7-bitness?
-                         :ascii :us-ascii :ansi_x3.4-1968)
-    1
-  (setf (sap-ref-8 sap tail) bits)
+(define-external-format (:latin-1 :latin1 :iso-8859-1)
+    1 t
+  (if (>= bits 256)
+      (stream-encoding-error stream bits)
+      (setf (sap-ref-8 sap tail) bits))

   (code-char byte))
 
   (code-char byte))
 

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

   (let ((bits (char-code byte)))
     (cond ((< bits #x80) 1)
          ((< bits #x800) 2)
   (let ((bits (char-code byte)))
     (cond ((< bits #x80) 1)
          ((< bits #x800) 2)

@@ -1130,19 +1317,32 @@
             (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 #xe0) 2)
        ((< byte #xf0) 3)
        (t 4))
   (code-char (ecase size
               (1 byte)
        ((< byte #xe0) 2)
        ((< byte #xf0) 3)
        (t 4))
   (code-char (ecase size
               (1 byte)

-              (2 (dpb byte (byte 5 6) (sap-ref-8 sap (1+ head))))
-              (3 (dpb byte (byte 4 12)
-                      (dpb (sap-ref-8 sap (1+ head)) (byte 6 6)
-                           (sap-ref-8 sap (+ 2 head)))))
-              (4 (dpb byte (byte 3 18)
-                      (dpb (sap-ref-8 sap (1+ head)) (byte 6 12)
-                           (dpb (sap-ref-8 sap (+ 2 head)) (byte 6 6)
-                                (sap-ref-8 sap (+ 3 head)))))))))
+              (2 (let ((byte2 (sap-ref-8 sap (1+ head))))
+                   (unless (<= #x80 byte2 #xbf)
+                     (return-from character-decode))
+                   (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))
+                   (dpb byte (byte 4 12) (dpb byte2 (byte 6 6) byte3))))
+              (4 (let ((byte2 (sap-ref-8 sap (1+ head)))
+                       (byte3 (sap-ref-8 sap (+ 2 head)))
+                       (byte4 (sap-ref-8 sap (+ 3 head))))
+                   (unless (and (<= #x80 byte2 #xbf)
+                                (<= #x80 byte3 #xbf)
+                                (<= #x80 byte4 #xbf))
+                     (return-from character-decode))
+                   (dpb byte (byte 3 18)
+                        (dpb byte2 (byte 6 12)
+                             (dpb byte3 (byte 6 6) byte4))))))))

 \f
 ;;;; utility functions (misc routines, etc)
 
 \f
 ;;;; utility functions (misc routines, etc)
 

@@ -1421,7 +1621,7 @@
        ;; appropriate value for the EXPECTED-TYPE slot..
        (error 'simple-type-error
               :datum fd-stream
        ;; appropriate value for the EXPECTED-TYPE slot..
        (error 'simple-type-error
               :datum fd-stream

-              :expected-type 'file-stream
+              :expected-type 'fd-stream

               :format-control "~S is not a stream associated with a file."
               :format-arguments (list fd-stream)))
      (multiple-value-bind (okay dev ino mode nlink uid gid rdev size
               :format-control "~S is not a stream associated with a file."
               :format-arguments (list fd-stream)))
      (multiple-value-bind (okay dev ino mode nlink uid gid rdev size

@@ -1438,7 +1638,7 @@
      (fd-stream-file-position fd-stream arg1))))
 
 (defun fd-stream-file-position (stream &optional newpos)
      (fd-stream-file-position fd-stream arg1))))
 
 (defun fd-stream-file-position (stream &optional newpos)

-  (declare (type file-stream stream)
+  (declare (type fd-stream stream)

           (type (or (alien sb!unix:off-t) (member nil :start :end)) newpos))
   (if (null newpos)
       (sb!sys:without-interrupts
           (type (or (alien sb!unix:off-t) (member nil :start :end)) newpos))
   (if (null newpos)
       (sb!sys:without-interrupts

@@ -1836,7 +2036,7 @@
 ;;;
 ;;; FIXME: misleading name, screwy interface
 (defun file-name (stream &optional new-name)
 ;;;
 ;;; FIXME: misleading name, screwy interface
 (defun file-name (stream &optional new-name)

-  (when (typep stream 'file-stream)
+  (when (typep stream 'fd-stream)

       (cond (new-name
             (setf (fd-stream-pathname stream) new-name)
             (setf (fd-stream-file stream)
       (cond (new-name
             (setf (fd-stream-pathname stream) new-name)
             (setf (fd-stream-file stream)

@@ -1853,7 +2053,7 @@
 ;;;; COMMON-LISP.)
 
 (defun file-string-length (stream object)
 ;;;; COMMON-LISP.)
 
 (defun file-string-length (stream object)

-  (declare (type (or string character) object) (type file-stream stream))
+  (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
   #!+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

@@ -1864,9 +2064,9 @@
     (string (length object))))
 
 (defun stream-external-format (stream)
     (string (length object))))
 
 (defun stream-external-format (stream)

-  (declare (type file-stream stream))
+  (declare (type fd-stream stream))

   #!+sb-doc
   #!+sb-doc

-  "Return the actual external format for file-streams, otherwise :DEFAULT."
-  (if (typep stream 'file-stream)
+  "Return the actual external format for fd-streams, otherwise :DEFAULT."
+  (if (typep stream 'fd-stream)

       (fd-stream-external-format stream)
       :default))
       (fd-stream-external-format stream)
       :default))