From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Wed, 13 Oct 2010 15:07:29 +0000 (+0000)
Subject: 1.0.43.52: correct char-size for :EXTERNAL-FORMAT :DEFAULT
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=765a042b5f968f285d8bd4a4ea1e897ca29abc8d;p=sbcl.git

1.0.43.52: correct char-size for :EXTERNAL-FORMAT :DEFAULT

 Fixes bug 657183.

 Make picking the char-size part of picking input/output routines,
 and make set-fd-stream-routines set FD-STREAM-CHAR-SIZE from it.

 For cleanliness sake, don't ever construct an FD-STREAM with an
 inconsistent external-format and char-size -- meaning the default
 external-format for the FD-STREAM structure cannot be :DEFAULT.
 ...this should not matter, but in case someone inspects an unfinished
 stream instance, at least things make a bit more sense.
---

diff --git a/NEWS b/NEWS
index 0b256df..4215598 100644
--- a/NEWS
+++ b/NEWS
@@ -56,6 +56,9 @@ changes relative to sbcl-1.0.43:
   * bug fix: the system used to signal bogus STYLE-WARNINGs when functions
     containing self-calls were recompiled with a new signature, and failed
     to warn when a self-call using the old signature was left in. (lp#655126)
+  * bug fix: incorrect FILE-POSITION on streams opened using :EXTERNAL-FORMAT
+    :DEFAULT when the default external had character size other than 8 bits.
+    (lp#657183)
 
 changes in sbcl-1.0.43 relative to sbcl-1.0.42:
   * incompatible change: FD-STREAMS no longer participate in the serve-event
diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 8fc27f7..a2940e1 100644
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -187,7 +187,8 @@
   (timeout nil :type (or single-float null))
   ;; pathname of the file this stream is opened to (returned by PATHNAME)
   (pathname nil :type (or pathname null))
-  (external-format :default)
+  ;; Not :DEFAULT, because we want to match CHAR-SIZE!
+  (external-format :latin-1)
   ;; fixed width, or function to call with a character
   (char-size 1 :type (or fixnum function))
   (output-bytes #'ill-out :type function)
@@ -791,6 +792,11 @@
   (octets-to-string-fun (missing-arg) :type function)
   (string-to-octets-fun (missing-arg) :type function))
 
+(defun ef-char-size (ef-entry)
+  (if (variable-width-external-format-p ef-entry)
+      (bytes-for-char-fun ef-entry)
+      (funcall (bytes-for-char-fun ef-entry) #\x)))
+
 (defun wrap-external-format-functions (external-format fun)
   (let ((result (%copy-external-format external-format)))
     (macrolet ((frob (accessor)
@@ -880,6 +886,7 @@
                 'character
                 1
                 (ef-write-n-bytes-fun entry)
+                (ef-char-size entry)
                 (canonize-external-format external-format entry)))))
   (dolist (entry *output-routines*)
     (when (and (subtypep type (first entry))
@@ -1226,6 +1233,7 @@
                 'character
                 1
                 (ef-read-n-chars-fun entry)
+                (ef-char-size entry)
                 (canonize-external-format external-format entry)))))
   (dolist (entry *input-routines*)
     (when (and (subtypep type (first entry))
@@ -1700,6 +1708,7 @@
          (character-stream-p (subtypep target-type 'character))
          (bivalent-stream-p (eq element-type :default))
          normalized-external-format
+         char-size
          (bin-routine #'ill-bin)
          (bin-type nil)
          (bin-size nil)
@@ -1743,24 +1752,23 @@
     (when output-p
       (setf (fd-stream-char-pos fd-stream) 0))
 
-    (when (and character-stream-p
-               (eq external-format :default))
+    (when (and character-stream-p (eq external-format :default))
       (/show0 "/getting default external format")
       (setf external-format (default-external-format)))
 
     (when input-p
       (when (or (not character-stream-p) bivalent-stream-p)
-        (multiple-value-setq (bin-routine bin-type bin-size read-n-characters
-                                          normalized-external-format)
-          (pick-input-routine (if bivalent-stream-p '(unsigned-byte 8)
-                                  target-type)
-                              external-format))
+        (setf (values bin-routine bin-type bin-size read-n-characters
+                      char-size normalized-external-format)
+              (pick-input-routine (if bivalent-stream-p '(unsigned-byte 8)
+                                      target-type)
+                                  external-format))
         (unless bin-routine
           (error "could not find any input routine for ~S" target-type)))
       (when character-stream-p
-        (multiple-value-setq (cin-routine cin-type cin-size read-n-characters
-                                          normalized-external-format)
-          (pick-input-routine target-type external-format))
+        (setf (values cin-routine cin-type cin-size read-n-characters
+                      char-size normalized-external-format)
+              (pick-input-routine target-type external-format))
         (unless cin-routine
           (error "could not find any input routine for ~S" target-type)))
       (setf (fd-stream-in fd-stream) cin-routine
@@ -1769,8 +1777,8 @@
       (setf input-size (or cin-size bin-size))
       (setf input-type (or cin-type bin-type))
       (when normalized-external-format
-        (setf (fd-stream-external-format fd-stream)
-              normalized-external-format))
+        (setf (fd-stream-external-format fd-stream) normalized-external-format
+              (fd-stream-char-size fd-stream) char-size))
       (when (= (or cin-size 1) (or bin-size 1) 1)
         (setf (fd-stream-n-bin fd-stream) ;XXX
               (if (and character-stream-p (not bivalent-stream-p))
@@ -1797,33 +1805,33 @@
 
     (when output-p
       (when (or (not character-stream-p) bivalent-stream-p)
-        (multiple-value-setq (bout-routine bout-type bout-size output-bytes
-                                           normalized-external-format)
-          (let ((buffering (fd-stream-buffering fd-stream)))
-            (if bivalent-stream-p
-                (pick-output-routine '(unsigned-byte 8)
-                                     (if (eq :line buffering)
-                                         :full
-                                         buffering)
-                                     external-format)
-                (pick-output-routine target-type buffering external-format))))
+        (setf (values bout-routine bout-type bout-size output-bytes
+                      char-size normalized-external-format)
+              (let ((buffering (fd-stream-buffering fd-stream)))
+                (if bivalent-stream-p
+                    (pick-output-routine '(unsigned-byte 8)
+                                         (if (eq :line buffering)
+                                             :full
+                                             buffering)
+                                         external-format)
+                    (pick-output-routine target-type buffering external-format))))
         (unless bout-routine
           (error "could not find any output routine for ~S buffered ~S"
                  (fd-stream-buffering fd-stream)
                  target-type)))
       (when character-stream-p
-        (multiple-value-setq (cout-routine cout-type cout-size output-bytes
-                                           normalized-external-format)
-          (pick-output-routine target-type
-                               (fd-stream-buffering fd-stream)
-                               external-format))
+        (setf (values cout-routine cout-type cout-size output-bytes
+                      char-size normalized-external-format)
+              (pick-output-routine target-type
+                                   (fd-stream-buffering fd-stream)
+                                   external-format))
         (unless cout-routine
           (error "could not find any output routine for ~S buffered ~S"
                  (fd-stream-buffering fd-stream)
                  target-type)))
       (when normalized-external-format
-        (setf (fd-stream-external-format fd-stream)
-              normalized-external-format))
+        (setf (fd-stream-external-format fd-stream) normalized-external-format
+              (fd-stream-char-size fd-stream) char-size))
       (when character-stream-p
         (setf (fd-stream-output-bytes fd-stream) output-bytes))
       (setf (fd-stream-out fd-stream) cout-routine
@@ -2220,9 +2228,7 @@
                                  :pathname pathname
                                  :buffering buffering
                                  :dual-channel-p dual-channel-p
-                                 :external-format external-format
                                  :bivalent-p (eq element-type :default)
-                                 :char-size (external-format-char-size external-format)
                                  :serve-events serve-events
                                  :timeout
                                  (if timeout
diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index 7ffffc2..7eb78ac 100644
--- a/src/code/stream.lisp
+++ b/src/code/stream.lisp
@@ -133,12 +133,9 @@
   (setf (ansi-stream-sout stream) #'closed-flame)
   (setf (ansi-stream-misc stream) #'closed-flame))
 
-;;;; file position and file length
+;;;; for file position and file length
 (defun external-format-char-size (external-format)
-  (let ((ef-entry (get-external-format external-format)))
-    (if (variable-width-external-format-p ef-entry)
-        (bytes-for-char-fun ef-entry)
-        (funcall (bytes-for-char-fun ef-entry) #\x))))
+  (ef-char-size (get-external-format external-format)))
 
 ;;; Call the MISC method with the :FILE-POSITION operation.
 #!-sb-fluid (declaim (inline ansi-stream-file-position))
diff --git a/tests/stream.impure.lisp b/tests/stream.impure.lisp
index 60c00c5..b6f0224 100644
--- a/tests/stream.impure.lisp
+++ b/tests/stream.impure.lisp
@@ -675,4 +675,35 @@
            (setf fifo nil))))
      sb-impl::*external-formats*)))
 
+(with-test (:name :bug-657183)
+  (let ((name (merge-pathnames "stream-impure.temp-test"))
+        (text '(#\GREEK_SMALL_LETTER_LAMDA
+                #\JAPANESE_BANK_SYMBOL
+                #\Space
+                #\HEAVY_BLACK_HEART))
+        (positions '(2 5 6 9))
+        (sb-impl::*default-external-format* :utf-8))
+    (unwind-protect
+         (progn
+           (with-open-file (f name :external-format :default :direction :output
+                              :if-exists :supersede)
+             (assert (eql 0 (file-position f)))
+             (mapc (lambda (char pos)
+                     (write-char char f)
+                     (assert (eql pos (file-position f))))
+                   text
+                   positions))
+           (with-open-file (f name :external-format :default :direction :input)
+             (assert (eql 0 (file-position f)))
+             (assert (eql (pop text) (read-char f)))
+             (assert (eql (file-position f) 2))
+             (assert (eql (pop text) (read-char f)))
+             (assert (eql (file-position f) 5))
+             (assert (eql (pop text) (read-char f)))
+             (assert (eql (file-position f) 6))
+             (assert (eql (pop text) (read-char f)))
+             (assert (eql (file-position f) 9))
+             (assert (eql (file-length f) 9))))
+      (ignore-errors (delete-file name)))))
+
 ;;; success
diff --git a/version.lisp-expr b/version.lisp-expr
index b711845..c269a61 100644
--- a/version.lisp-expr
+++ b/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.43.51"
+"1.0.43.52"