1.0.0.2: TRACE :ENCAPSULATE NIL, plus other minor Windows improvements

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

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 3edf77e..567c5b4 100644 (file)
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -140,6 +140,16 @@
          :stream stream
          :code code))
 
          :stream stream
          :code code))
 

+(defun c-string-encoding-error (external-format code)
+  (error 'c-string-encoding-error
+         :external-format external-format
+         :code code))
+
+(defun c-string-decoding-error (external-format octets)
+  (error 'c-string-decoding-error
+         :external-format external-format
+         :octets octets))
+

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

@@ -169,6 +179,16 @@
                 (format stream "~@<Skip output of this character.~@:>"))
       (throw 'output-nothing nil))))
 
                 (format stream "~@<Skip output of this character.~@:>"))
       (throw 'output-nothing nil))))
 

+(defun external-format-encoding-error (stream code)
+  (if (streamp stream)
+    (stream-encoding-error-and-handle stream code)
+    (c-string-encoding-error stream code)))
+
+(defun external-format-decoding-error (stream octet-count)
+  (if (streamp stream)
+    (stream-decoding-error stream octet-count)
+    (c-string-decoding-error stream octet-count)))
+

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

@@ -325,6 +345,7 @@
                      (intern (format nil name-fmt (string (car buffering))))))
                 `(progn
                    (defun ,function (stream byte)
                      (intern (format nil name-fmt (string (car buffering))))))
                 `(progn
                    (defun ,function (stream byte)

+                     (declare (ignorable byte))

                      (output-wrapper/variable-width (stream ,size ,buffering ,restart)
                        ,@body))
                    (setf *output-routines*
                      (output-wrapper/variable-width (stream ,size ,buffering ,restart)
                        ,@body))
                    (setf *output-routines*

@@ -429,6 +450,24 @@
                            (fd-stream-obuf-tail stream))
         byte))
 
                            (fd-stream-obuf-tail stream))
         byte))
 

+#+#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or))
+(progn
+  (def-output-routines ("OUTPUT-UNSIGNED-LONG-LONG-~A-BUFFERED"
+                        8
+                        nil
+                        (:none (unsigned-byte 64))
+                        (:full (unsigned-byte 64)))
+    (setf (sap-ref-64 (fd-stream-obuf-sap stream) (fd-stream-obuf-tail stream))
+          byte))
+  (def-output-routines ("OUTPUT-SIGNED-LONG-LONG-~A-BUFFERED"
+                        8
+                        nil
+                        (:none (signed-byte 64))
+                        (:full (signed-byte 64)))
+    (setf (signed-sap-ref-64 (fd-stream-obuf-sap stream)
+                             (fd-stream-obuf-tail stream))
+          byte)))
+

 ;;; Do the actual output. If there is space to buffer the string,
 ;;; buffer it. If the string would normally fit in the buffer, but
 ;;; doesn't because of other stuff in the buffer, flush the old noise
 ;;; Do the actual output. If there is space to buffer the string,
 ;;; buffer it. If the string would normally fit in the buffer, but
 ;;; doesn't because of other stuff in the buffer, flush the old noise

@@ -551,13 +590,22 @@
   element-type, string input function name, character input function name,
   and string output function name.")
 
   element-type, string input function name, character input function name,
   and string output function name.")
 

+(defun get-external-format (external-format)
+  (dolist (entry *external-formats*)
+    (when (member external-format (first entry))
+      (return entry))))
+
+(defun get-external-format-function (external-format index)
+  (let ((entry (get-external-format external-format)))
+    (when entry (nth index entry))))
+

 ;;; Find an output routine to use given the type and buffering. Return
 ;;; as multiple values the routine, the real type transfered, and the
 ;;; number of bytes per element.
 (defun pick-output-routine (type buffering &optional external-format)
   (when (subtypep type 'character)
 ;;; Find an output routine to use given the type and buffering. Return
 ;;; as multiple values the routine, the real type transfered, and the
 ;;; number of bytes per element.
 (defun pick-output-routine (type buffering &optional external-format)
   (when (subtypep type 'character)

-    (dolist (entry *external-formats*)
-      (when (member external-format (first entry))
+    (let ((entry (get-external-format external-format)))
+      (when entry

         (return-from pick-output-routine
           (values (symbol-function (nth (ecase buffering
                                           (:none 4)
         (return-from pick-output-routine
           (values (symbol-function (nth (ecase buffering
                                           (:none 4)

@@ -752,6 +800,7 @@
                                                       ,stream-var)
                                                      (fd-stream-ibuf-head
                                                       ,stream-var))))
                                                       ,stream-var)
                                                      (fd-stream-ibuf-head
                                                       ,stream-var))))

+                               (declare (ignorable byte))

                                (setq size ,bytes)
                                (input-at-least ,stream-var size)
                                (setq ,element-var (locally ,@read-forms))
                                (setq size ,bytes)
                                (input-at-least ,stream-var size)
                                (setq ,element-var (locally ,@read-forms))

@@ -856,7 +905,14 @@
                    ((signed-byte 32) 4 sap head)
   (signed-sap-ref-32 sap head))
 
                    ((signed-byte 32) 4 sap head)
   (signed-sap-ref-32 sap head))
 

-
+#+#.(cl:if (cl:= sb!vm:n-word-bits 64) '(and) '(or))
+(progn
+  (def-input-routine input-unsigned-64bit-byte
+      ((unsigned-byte 64) 8 sap head)
+    (sap-ref-64 sap head))
+  (def-input-routine input-signed-64bit-byte
+      ((signed-byte 64) 8 sap head)
+    (signed-sap-ref-64 sap head)))

 
 ;;; Find an input routine to use given the type. Return as multiple
 ;;; values the routine, the real type transfered, and the number of
 
 ;;; Find an input routine to use given the type. Return as multiple
 ;;; values the routine, the real type transfered, and the number of

@@ -1001,6 +1057,16 @@
     (when sizer
       (loop for char across string summing (funcall sizer char)))))
 
     (when sizer
       (loop for char across string summing (funcall sizer char)))))
 

+(defun find-external-format (external-format)
+  (when external-format
+    (find external-format *external-formats* :test #'member :key #'car)))
+
+(defun variable-width-external-format-p (ef-entry)
+  (when (eighth ef-entry) t))
+
+(defun bytes-for-char-fun (ef-entry)
+  (if ef-entry (symbol-function (ninth ef-entry)) (constantly 1)))
+

 ;;; FIXME: OAOOM here vrt. *EXTERNAL-FORMAT-FUNCTIONS* in fd-stream.lisp
 (defmacro define-external-format (external-format size output-restart
                                   out-expr in-expr)
 ;;; FIXME: OAOOM here vrt. *EXTERNAL-FORMAT-FUNCTIONS* in fd-stream.lisp
 (defmacro define-external-format (external-format size output-restart
                                   out-expr in-expr)

@@ -1009,7 +1075,9 @@
          (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))
          (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))

-         (size-function (symbolicate "BYTES-FOR-CHAR/" name)))
+         (size-function (symbolicate "BYTES-FOR-CHAR/" name))
+         (read-c-string-function (symbolicate "READ-FROM-C-STRING/" name))
+         (output-c-string-function (symbolicate "OUTPUT-TO-C-STRING/" name)))

     `(progn
       (defun ,size-function (byte)
         (declare (ignore byte))
     `(progn
       (defun ,size-function (byte)
         (declare (ignore byte))

@@ -1113,13 +1181,58 @@
       (def-input-routine ,in-char-function (character ,size sap head)
         (let ((byte (sap-ref-8 sap head)))
           ,in-expr))
       (def-input-routine ,in-char-function (character ,size sap head)
         (let ((byte (sap-ref-8 sap head)))
           ,in-expr))

+      (defun ,read-c-string-function (sap element-type)
+        (declare (type system-area-pointer sap)
+                 (type (member character base-char) element-type))
+        (locally
+            (declare (optimize (speed 3) (safety 0)))
+          (let* ((stream ,name)
+                 (length (loop for head of-type index upfrom 0 by ,size
+                            for count of-type index upto (1- ARRAY-DIMENSION-LIMIT)
+                            for byte = (sap-ref-8 sap head)
+                            for char of-type character = ,in-expr
+                            until (zerop (char-code char))
+                            finally (return count)))
+                 (string (make-string length :element-type element-type)))
+            (declare (ignorable stream)
+                     (type index length)
+                     (type string string))
+            (/show0 before-copy-loop)
+            (loop for head of-type index upfrom 0 by ,size
+               for index of-type index below length
+               for byte = (sap-ref-8 sap head)
+               for char of-type character = ,in-expr
+               do (setf (aref string index) char))
+            string))) ;; last loop rewrite to dotimes?
+        (defun ,output-c-string-function (string)
+          (declare (type simple-string string))
+          (locally
+              (declare (optimize (speed 3) (safety 0)))
+            (let* ((length (length string))
+                   (buffer (make-array (* (1+ length) ,size) :element-type '(unsigned-byte 8)))
+                   (sap (sb!sys:vector-sap buffer))
+                   (tail 0)
+                   (stream ,name))
+              (declare (type index length tail)
+                       (type system-area-pointer sap))
+              (dotimes (i length)
+                (let* ((byte (aref string i))
+                       (bits (char-code byte)))
+                  (declare (ignorable byte bits))
+                  ,out-expr)
+                (incf tail ,size))
+              (let* ((bits 0)
+                     (byte (code-char bits)))
+                (declare (ignorable bits byte))
+                ,out-expr)
+              buffer)))

       (setf *external-formats*
        (cons '(,external-format ,in-function ,in-char-function ,out-function
                ,@(mapcar #'(lambda (buffering)
                              (intern (format nil format (string buffering))))
                          '(:none :line :full))
                nil ; no resync-function
       (setf *external-formats*
        (cons '(,external-format ,in-function ,in-char-function ,out-function
                ,@(mapcar #'(lambda (buffering)
                              (intern (format nil format (string buffering))))
                          '(:none :line :full))
                nil ; no resync-function

-               ,size-function)
+               ,size-function ,read-c-string-function ,output-c-string-function)

         *external-formats*)))))
 
 (defmacro define-external-format/variable-width
         *external-formats*)))))
 
 (defmacro define-external-format/variable-width

@@ -1131,9 +1244,12 @@
          (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name))
          (in-char-function (symbolicate "INPUT-CHAR/" name))
          (resync-function (symbolicate "RESYNC/" name))
          (in-function (symbolicate "FD-STREAM-READ-N-CHARACTERS/" name))
          (in-char-function (symbolicate "INPUT-CHAR/" name))
          (resync-function (symbolicate "RESYNC/" name))

-         (size-function (symbolicate "BYTES-FOR-CHAR/" name)))
+         (size-function (symbolicate "BYTES-FOR-CHAR/" name))
+         (read-c-string-function (symbolicate "READ-FROM-C-STRING/" name))
+         (output-c-string-function (symbolicate "OUTPUT-TO-C-STRING/" name)))

     `(progn
       (defun ,size-function (byte)
     `(progn
       (defun ,size-function (byte)

+        (declare (ignorable byte))

         ,out-size-expr)
       (defun ,out-function (stream string flush-p start end)
         (let ((start (or start 0))
         ,out-size-expr)
       (defun ,out-function (stream string flush-p start end)
         (let ((start (or start 0))

@@ -1218,6 +1334,7 @@
               (setf decode-break-reason
                     (block decode-break-reason
                       (let ((byte (sap-ref-8 sap head)))
               (setf decode-break-reason
                     (block decode-break-reason
                       (let ((byte (sap-ref-8 sap head)))

+                        (declare (ignorable byte))

                         (setq size ,in-size-expr)
                         (when (> size (- tail head))
                           (return))
                         (setq size ,in-size-expr)
                         (when (> size (- tail head))
                           (return))

@@ -1262,6 +1379,7 @@
                                                            ,in-size-expr
                                                            sap head)
         (let ((byte (sap-ref-8 sap head)))
                                                            ,in-size-expr
                                                            sap head)
         (let ((byte (sap-ref-8 sap head)))

+          (declare (ignorable byte))

           ,in-expr))
       (defun ,resync-function (stream)
         (loop (input-at-least stream 2)
           ,in-expr))
       (defun ,resync-function (stream)
         (loop (input-at-least stream 2)

@@ -1271,19 +1389,97 @@
                                (head (fd-stream-ibuf-head stream))
                                (byte (sap-ref-8 sap head))
                                (size ,in-size-expr))
                                (head (fd-stream-ibuf-head stream))
                                (byte (sap-ref-8 sap head))
                                (size ,in-size-expr))

+                          (declare (ignorable byte))

                           (input-at-least stream size)
                           (let ((sap (fd-stream-ibuf-sap stream))
                                 (head (fd-stream-ibuf-head stream)))
                             ,in-expr))
                         nil)
                 (return))))
                           (input-at-least stream size)
                           (let ((sap (fd-stream-ibuf-sap stream))
                                 (head (fd-stream-ibuf-head stream)))
                             ,in-expr))
                         nil)
                 (return))))

+      (defun ,read-c-string-function (sap element-type)
+        (declare (type system-area-pointer sap))
+        (locally
+            (declare (optimize (speed 3) (safety 0)))
+          (let* ((stream ,name)
+                 (size 0) (head 0) (byte 0) (char nil)
+                 (decode-break-reason nil)
+                 (length (dotimes (count (1- ARRAY-DIMENSION-LIMIT) count)
+                           (setf decode-break-reason
+                                 (block decode-break-reason
+                                   (setf byte (sap-ref-8 sap head)
+                                         size ,in-size-expr
+                                         char ,in-expr)
+                                   (incf head size)
+                                   nil))
+                           (when decode-break-reason
+                             (c-string-decoding-error ,name decode-break-reason))
+                           (when (zerop (char-code char))
+                             (return count))))
+                 (string (make-string length :element-type element-type)))
+            (declare (ignorable stream)
+                     (type index head length) ;; size
+                     (type (unsigned-byte 8) byte)
+                     (type (or null character) char)
+                     (type string string))
+            (setf head 0)
+            (dotimes (index length string)
+              (setf decode-break-reason
+                    (block decode-break-reason
+                      (setf byte (sap-ref-8 sap head)
+                            size ,in-size-expr
+                            char ,in-expr)
+                      (incf head size)
+                      nil))
+              (when decode-break-reason
+                (c-string-decoding-error ,name decode-break-reason))
+              (setf (aref string index) char)))))
+
+      (defun ,output-c-string-function (string)
+        (declare (type simple-string string))
+        (locally
+            (declare (optimize (speed 3) (safety 0)))
+          (let* ((length (length string))
+                 (char-length (make-array (1+ length) :element-type 'index))
+                 (buffer-length
+                  (+ (loop for i of-type index below length
+                        for byte of-type character = (aref string i)
+                        for bits = (char-code byte)
+                        sum (setf (aref char-length i)
+                                  (the index ,out-size-expr)))
+                     (let* ((byte (code-char 0))
+                            (bits (char-code byte)))
+                       (declare (ignorable byte bits))
+                       (setf (aref char-length length)
+                             (the index ,out-size-expr)))))
+                 (tail 0)
+                 (buffer (make-array buffer-length :element-type '(unsigned-byte 8)))
+                 (sap (sb!sys:vector-sap buffer))
+                 stream)
+            (declare (type index length buffer-length tail)
+                     (type system-area-pointer sap)
+                     (type null stream)
+                     (ignorable stream))
+            (loop for i of-type index below length
+               for byte of-type character = (aref string i)
+               for bits = (char-code byte)
+               for size of-type index = (aref char-length i)
+               do (prog1
+                      ,out-expr
+                    (incf tail size)))
+            (let* ((bits 0)
+                   (byte (code-char bits))
+                   (size (aref char-length length)))
+              (declare (ignorable bits byte size))
+              ,out-expr)
+            buffer)))
+

       (setf *external-formats*
        (cons '(,external-format ,in-function ,in-char-function ,out-function
                ,@(mapcar #'(lambda (buffering)
                              (intern (format nil format (string buffering))))
                          '(:none :line :full))
                ,resync-function
       (setf *external-formats*
        (cons '(,external-format ,in-function ,in-char-function ,out-function
                ,@(mapcar #'(lambda (buffering)
                              (intern (format nil format (string buffering))))
                          '(:none :line :full))
                ,resync-function

-               ,size-function)
+               ,size-function ,read-c-string-function ,output-c-string-function)

         *external-formats*)))))
 
 ;;; Multiple names for the :ISO{,-}8859-* families are needed because on
         *external-formats*)))))
 
 ;;; Multiple names for the :ISO{,-}8859-* families are needed because on

@@ -1292,7 +1488,7 @@
 (define-external-format (:latin-1 :latin1 :iso-8859-1 :iso8859-1)
     1 t
   (if (>= bits 256)
 (define-external-format (:latin-1 :latin1 :iso-8859-1 :iso8859-1)
     1 t
   (if (>= bits 256)

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

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

@@ -1300,7 +1496,7 @@
                          :iso-646 :iso-646-us :|646|)
     1 t
   (if (>= bits 128)
                          :iso-646 :iso-646-us :|646|)
     1 t
   (if (>= bits 128)

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

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

@@ -1331,7 +1527,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-and-handle stream bits)
+        (external-format-encoding-error 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)))
 

@@ -1362,10 +1558,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-and-handle stream byte))
+                  (external-format-encoding-error 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-and-handle stream byte))))
+                  (external-format-encoding-error 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

@@ -1582,32 +1778,41 @@
   (declare (ignore arg2))
   (case operation
     (:listen
   (declare (ignore arg2))
   (case operation
     (:listen

-     (or (not (eql (fd-stream-ibuf-head fd-stream)
-                   (fd-stream-ibuf-tail fd-stream)))
-         (fd-stream-listen fd-stream)
-         #!+win32
-         (setf (fd-stream-listen fd-stream)
-               (sb!win32:fd-listen (fd-stream-fd fd-stream)))
-         #!-win32
-         (setf (fd-stream-listen fd-stream)
-               (if (sysread-may-block-p fd-stream)
-                 nil
-                 ;; select(2) and CL:LISTEN have slightly different
-                 ;; semantics.  The former returns that an FD is
-                 ;; readable when a read operation wouldn't block.
-                 ;; That includes EOF.  However, LISTEN must return
-                 ;; NIL at EOF.
-                 (progn (catch 'eof-input-catcher
-                          ;; r-b/f too calls select, but it shouldn't
-                          ;; block as long as read can return once w/o
-                          ;; blocking
-                          (refill-buffer/fd fd-stream))
-                        (fd-stream-listen fd-stream))))))
+     (labels ((do-listen ()
+                (or (not (eql (fd-stream-ibuf-head fd-stream)
+                              (fd-stream-ibuf-tail fd-stream)))
+                    (fd-stream-listen fd-stream)
+                    #!+win32
+                    (sb!win32:fd-listen (fd-stream-fd fd-stream))
+                    #!-win32
+                    ;; If the read can block, LISTEN will certainly return NIL.
+                    (if (sysread-may-block-p fd-stream)
+                        nil
+                        ;; Otherwise select(2) and CL:LISTEN have slightly
+                        ;; different semantics.  The former returns that an FD
+                        ;; is readable when a read operation wouldn't block.
+                        ;; That includes EOF.  However, LISTEN must return NIL
+                        ;; at EOF.
+                        (progn (catch 'eof-input-catcher
+                                 ;; r-b/f too calls select, but it shouldn't
+                                 ;; block as long as read can return once w/o
+                                 ;; blocking
+                                 (refill-buffer/fd fd-stream))
+                               ;; At this point either IBUF-HEAD != IBUF-TAIL
+                               ;; and FD-STREAM-LISTEN is NIL, in which case
+                               ;; we should return T, or IBUF-HEAD ==
+                               ;; IBUF-TAIL and FD-STREAM-LISTEN is :EOF, in
+                               ;; which case we should return :EOF for this
+                               ;; call and all future LISTEN call on this stream.
+                               ;; Call ourselves again to determine which case
+                               ;; applies.
+                               (do-listen))))))
+       (do-listen)))

     (:unread
      (setf (fd-stream-unread fd-stream) arg1)
      (setf (fd-stream-listen fd-stream) t))
     (:close
     (:unread
      (setf (fd-stream-unread fd-stream) arg1)
      (setf (fd-stream-listen fd-stream) t))
     (:close

-     (cond (arg1 ; We got us an abort on our hands.
+     (cond (arg1                    ; We got us an abort on our hands.

             (when (fd-stream-handler fd-stream)
               (sb!sys:remove-fd-handler (fd-stream-handler fd-stream))
               (setf (fd-stream-handler fd-stream) nil))
             (when (fd-stream-handler fd-stream)
               (sb!sys:remove-fd-handler (fd-stream-handler fd-stream))
               (setf (fd-stream-handler fd-stream) nil))

@@ -1688,11 +1893,11 @@
        (setf (fd-stream-listen fd-stream) nil))
      #!-win32
      (catch 'eof-input-catcher
        (setf (fd-stream-listen fd-stream) nil))
      #!-win32
      (catch 'eof-input-catcher

-       (loop
-          until (sysread-may-block-p fd-stream)
-          do (refill-buffer/fd fd-stream)
-            (setf (fd-stream-ibuf-head fd-stream) 0)
-            (setf (fd-stream-ibuf-tail fd-stream) 0))
+       (loop until (sysread-may-block-p fd-stream)
+             do
+             (refill-buffer/fd fd-stream)
+             (setf (fd-stream-ibuf-head fd-stream) 0)
+             (setf (fd-stream-ibuf-tail fd-stream) 0))

        t))
     (:force-output
      (flush-output-buffer fd-stream))
        t))
     (:force-output
      (flush-output-buffer fd-stream))

@@ -1724,7 +1929,7 @@
               :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

-                           atime mtime ctime blksize blocks)
+                                atime mtime ctime blksize blocks)

          (sb!unix:unix-fstat (fd-stream-fd fd-stream))
        (declare (ignore ino nlink uid gid rdev
                         atime mtime ctime blksize blocks))
          (sb!unix:unix-fstat (fd-stream-fd fd-stream))
        (declare (ignore ino nlink uid gid rdev
                         atime mtime ctime blksize blocks))

@@ -1881,8 +2086,8 @@
 ;;; Pick a name to use for the backup file for the :IF-EXISTS
 ;;; :RENAME-AND-DELETE and :RENAME options.
 (defun pick-backup-name (name)
 ;;; Pick a name to use for the backup file for the :IF-EXISTS
 ;;; :RENAME-AND-DELETE and :RENAME options.
 (defun pick-backup-name (name)

-  (declare (type simple-base-string name))
-  (concatenate 'simple-base-string name ".bak"))
+  (declare (type simple-string name))
+  (concatenate 'simple-string name ".bak"))

 
 ;;; Ensure that the given arg is one of the given list of valid
 ;;; things. Allow the user to fix any problems.
 
 ;;; Ensure that the given arg is one of the given list of valid
 ;;; things. Allow the user to fix any problems.

@@ -2114,11 +2319,14 @@
   (setf *available-buffers* nil)
   (with-output-to-string (*error-output*)
     (setf *stdin*
   (setf *available-buffers* nil)
   (with-output-to-string (*error-output*)
     (setf *stdin*

-          (make-fd-stream 0 :name "standard input" :input t :buffering :line))
+          (make-fd-stream 0 :name "standard input" :input t :buffering :line
+                            #!+win32 :external-format #!+win32 (sb!win32::console-input-codepage)))

     (setf *stdout*
     (setf *stdout*

-          (make-fd-stream 1 :name "standard output" :output t :buffering :line))
+          (make-fd-stream 1 :name "standard output" :output t :buffering :line
+                            #!+win32 :external-format #!+win32 (sb!win32::console-output-codepage)))

     (setf *stderr*
     (setf *stderr*

-          (make-fd-stream 2 :name "standard error" :output t :buffering :line))
+          (make-fd-stream 2 :name "standard error" :output t :buffering :line
+                            #!+win32 :external-format #!+win32 (sb!win32::console-output-codepage)))

     (let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string))
            (tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666)))
       (if tty
     (let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string))
            (tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666)))
       (if tty