0.8.20.6:
[sbcl.git] / src / code / fd-stream.lisp
index 528bd52..ea3e116 100644 (file)
       (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)
-           ;; 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
@@ -89,7 +83,7 @@
   (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))))
         :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
 ;;; 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.
       (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)
         `(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))
         (: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)
         `(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))
         (: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
                               (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*
 
 ;;; 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
                               (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*
                                   (cdr buffering)))))))
            bufferings)))
 
+;;; FIXME: is this used anywhere any more?
 (def-output-routines ("OUTPUT-CHAR-~A-BUFFERED"
                      1
+                      t
                      (:none character)
                      (:line character)
                      (:full character))
 
 (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))
 
 (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)
 
 (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))
 
 (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)
 
 (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))
 
 (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)
              (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)
                                    (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)
              (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)
                                    (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)
           (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))
+       (retry-var (gensym))
        (element-var (gensym)))
     `(let ((,stream-var ,stream)
           (size 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)
                    (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)
-       (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)))
 ;;; 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
       (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)))
 
-(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))))
          (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))
-         (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))
-           (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)
-                   (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)
-             (flush-output-buffer fd-stream)))
+             (flush-output-buffer stream)))
          (when flush-p
-           (flush-output-buffer fd-stream))))
+           (flush-output-buffer stream))))
       (def-output-routines (,format
                            ,size
+                            ,output-restart
                            (:none character)
                            (:line character)
                            (:full character))
          ,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
                         '(: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))))
                                (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))
            (flush-output-buffer fd-stream))))
       (def-output-routines/variable-width (,format
                                           ,out-size-expr
+                                           ,output-restart
                                           ,external-format
                                           (:none character)
                                           (:line character)
          ,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
                 (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)))
-             (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.
       (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))
+      (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))))
-                        '(:none :line :full)))
+                        '(:none :line :full))
+              ,resync-function)
        *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))
+
+(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))
 
-(define-external-format/variable-width (:utf-8 :utf8)
+#!+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)
             (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)
-              (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)
 
        ;; 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
      (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
 ;;;
 ;;; 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)
 ;;;; 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
     (string (length object))))
 
 (defun stream-external-format (stream)
-  (declare (type file-stream stream))
+  (declare (type fd-stream stream))
   #!+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))