1.0.32.23: use :replacement in the external format for standard IO st…

…reams

For *terminal-io*, a bidirectional stream, we have to make an arbitrary
choice on Windows, where in theory the input and output code pages can
differ.  We arbitrarily choose the output format; I have no idea whether
this matters.

NEWS

@@ -19,6 +19,11 @@ changes relative to sbcl-1.0.32:
        (:<encoding> :replacement <character>) as an external format which will
        automatically substitute <character> on encoding or decoding errors for
        streams and for STRING-TO-OCTETS and its inverse.
+    ** improvement: the file streams underlying the standard streams (such as
+       *STANDARD-INPUT*, *TERMINAL-IO*) are opened with an external format 
+       which uses the replacement mechanism to handle encoding errors,
+       preventing various infinite error chains and unrecoverable I/O
+       confusion.
     ** minor incompatible change: the utf-8 external format now correctly
        refuses to encode Lisp characters in the surrogate range (char-codes
        between #xd800 and #xdfff).

src/code/external-formats/enc-basic.lisp

@@ -383,6 +383,7 @@
 (instantiate-octets-definition define-utf8->string)
 
 (define-external-format/variable-width (:utf-8 :utf8) t
+  #!+sb-unicode (code-char #xfffd) #!-sb-unicode #\?
   (let ((bits (char-code byte)))
     (cond ((< bits #x80) 1)
           ((< bits #x800) 2)

src/code/external-formats/mb-util.lisp

@@ -248,6 +248,12 @@
 
        ;; for fd-stream.lisp
        (define-external-format/variable-width ,aliases t
+         ;; KLUDGE: it so happens that at present (2009-10-22) none of
+         ;; the external formats defined with
+         ;; define-multibyte-encoding can encode the unicode
+         ;; replacement character, so we hardcode the preferred
+         ;; replacement here.
+         #\?
          (mb-char-len (or (,ucs-to-mb (char-code byte)) -1))
          (let ((mb (,ucs-to-mb bits)))
            (if (null mb)

src/code/external-formats/ucs-2.lisp

@@ -190,6 +190,7 @@
 (instantiate-octets-definition define-ucs-2->string)
 
 (define-external-format/variable-width (:ucs-2le :ucs2le #!+win32 :ucs2 #!+win32 :ucs-2) t
+  (code-char #xfffd)
   2
   (if (< bits #x10000)
       (setf (sap-ref-16le sap tail) bits)
@@ -200,6 +201,7 @@
   string->ucs-2le)
 
 (define-external-format/variable-width (:ucs-2be :ucs2be) t
+  (code-char #xfffd)
   2
   (if (< bits #x10000)
       (setf (sap-ref-16be sap tail) bits)

src/code/fd-stream.lisp

@@ -754,6 +754,7 @@
   ;; All the names that can refer to this external format.  The first
   ;; one is the canonical name.
   (names (missing-arg) :type list :read-only t)
+  (default-replacement-character (missing-arg) :type character)
   (read-n-chars-fun (missing-arg) :type function)
   (read-char-fun (missing-arg) :type function)
   (write-n-bytes-fun (missing-arg) :type function)
@@ -1388,16 +1389,16 @@
     (canonical-name (&rest other-names)
      out-form in-form octets-to-string-symbol string-to-octets-symbol)
   `(define-external-format/variable-width (,canonical-name ,@other-names)
-     t 1
+     t #\? 1
      ,out-form
      1
      ,in-form
      ,octets-to-string-symbol
      ,string-to-octets-symbol))
 
 (defmacro define-external-format/variable-width
-    (external-format output-restart out-size-expr
-     out-expr in-size-expr in-expr
+    (external-format output-restart replacement-character
+     out-size-expr out-expr in-size-expr in-expr
      octets-to-string-sym string-to-octets-sym)
   (let* ((name (first external-format))
          (out-function (symbolicate "OUTPUT-BYTES/" name))
@@ -1646,6 +1647,7 @@
 
       (let ((entry (%make-external-format
                     :names ',external-format
+                    :default-replacement-character ,replacement-character
                     :read-n-chars-fun #',in-function
                     :read-char-fun #',in-char-function
                     :write-n-bytes-fun #',out-function
@@ -2455,6 +2457,14 @@
     (without-package-locks
         (makunbound '*available-buffers*))))
 
+(defun stdstream-external-format (outputp)
+  (declare (ignorable outputp))
+  (let* ((keyword #!+win32 (if outputp (sb!win32::console-output-codepage) (sb!win32::console-input-codepage))
+                  #!-win32 (default-external-format))
+         (ef (get-external-format keyword))
+         (replacement (ef-default-replacement-character ef)))
+    `(,keyword :replacement ,replacement)))
+
 ;;; This is called whenever a saved core is restarted.
 (defun stream-reinit (&optional init-buffers-p)
   (when init-buffers-p
@@ -2464,22 +2474,20 @@
   (with-output-to-string (*error-output*)
     (setf *stdin*
           (make-fd-stream 0 :name "standard input" :input t :buffering :line
-                            #!+win32 :external-format #!+win32 (sb!win32::console-input-codepage)))
+                            :external-format (stdstream-external-format nil)))
     (setf *stdout*
           (make-fd-stream 1 :name "standard output" :output t :buffering :line
-                            #!+win32 :external-format #!+win32 (sb!win32::console-output-codepage)))
+                            :external-format (stdstream-external-format t)))
     (setf *stderr*
           (make-fd-stream 2 :name "standard error" :output t :buffering :line
-                            #!+win32 :external-format #!+win32 (sb!win32::console-output-codepage)))
+                            :external-format (stdstream-external-format t)))
     (let* ((ttyname #.(coerce "/dev/tty" 'simple-base-string))
            (tty (sb!unix:unix-open ttyname sb!unix:o_rdwr #o666)))
       (if tty
           (setf *tty*
-                (make-fd-stream tty
-                                :name "the terminal"
-                                :input t
-                                :output t
-                                :buffering :line
+                (make-fd-stream tty :name "the terminal"
+                                :input t :output t :buffering :line
+                                :external-format (stdstream-external-format t)
                                 :auto-close t))
           (setf *tty* (make-two-way-stream *stdin* *stdout*))))
     (princ (get-output-stream-string *error-output*) *stderr*))

version.lisp-expr

@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.32.22"
+"1.0.32.23"