From 1f26211fbddc8e284849b0944a4309a50046ce40 Mon Sep 17 00:00:00 2001
From: Richard M Kreuter <kreuter@users.sourceforge.net>
Date: Sat, 4 Apr 2009 01:05:52 +0000
Subject: [PATCH] 1.0.27.1: Fix binary input after UNREAD-CHAR on bivalent
 streams.

* After an UNREAD-CHAR, READ-BYTE returned a character, and
  READ-SEQUENCE with an octet buffer failed when trying to store a
  character into the buffer.
---
 src/code/fd-stream.lisp  |   17 ++++++++++++++--
 tests/stream.impure.lisp |   51 ++++++++++++++++++++++++++++++++++++++++++++++
 version.lisp-expr        |    2 +-
 3 files changed, 67 insertions(+), 3 deletions(-)

diff --git a/src/code/fd-stream.lisp b/src/code/fd-stream.lisp
index 771cd10..825933b 100644
--- a/src/code/fd-stream.lisp
+++ b/src/code/fd-stream.lisp
@@ -187,7 +187,10 @@
   (external-format :default)
   ;; fixed width, or function to call with a character
   (char-size 1 :type (or fixnum function))
-  (output-bytes #'ill-out :type function))
+  (output-bytes #'ill-out :type function)
+  ;; a boolean indicating whether the stream is bivalent.  For
+  ;; internal use only.
+  (bivalent-p nil :type boolean))
 (def!method print-object ((fd-stream fd-stream) stream)
   (declare (type stream stream))
   (print-unreadable-object (fd-stream stream :type t :identity t)
@@ -2041,7 +2044,16 @@
                                  (do-listen)))))))
        (do-listen)))
     (:unread
-     (setf (fd-stream-unread fd-stream) arg1)
+     ;; If the stream is bivalent, the user might follow an
+     ;; unread-char with a read-byte.  In this case, the bookkeeping
+     ;; is simpler if we adjust the buffer head by the number of code
+     ;; units in the character.
+     ;; FIXME: there has to be a proper way to check for bivalence,
+     ;; right?
+     (if (fd-stream-bivalent-p fd-stream)
+         (decf (buffer-head (fd-stream-ibuf fd-stream))
+               (fd-stream-character-size fd-stream arg1))
+         (setf (fd-stream-unread fd-stream) arg1))
      (setf (fd-stream-listen fd-stream) t))
     (:close
      ;; Drop input buffers
@@ -2315,6 +2327,7 @@
                                  :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)
                                  :timeout
                                  (if timeout
diff --git a/tests/stream.impure.lisp b/tests/stream.impure.lisp
index f39e3c0..3540257 100644
--- a/tests/stream.impure.lisp
+++ b/tests/stream.impure.lisp
@@ -526,5 +526,56 @@
       (assert (= 3 (read-sequence buffer s :start 2 :end 3)))
       (file-position s :end)
       (assert (= 3 (read-sequence buffer s :start 3))))))
+
+;;; In 1.0.27 (and also 0.9.16; presumably in between, too), binary
+;;; input operations on a bivalent stream did something bad after
+;;; unread-char: READ-BYTE would return the character, and
+;;; READ-SEQUENCE into a byte buffer would lose when attempting to
+;;; store the character in the vector.
+(let ((pathname "bivalent-stream-unread-char-test.tmp"))
+  (with-open-file (s pathname
+                     :element-type :default
+                     :direction :io :if-exists :rename)
+    (write-char #\a s)
+    (file-position s :start)
+    (unread-char (read-char s) s)
+    (assert (integerp (read-byte s))))
+  (delete-file pathname))
+
+(let ((pathname "bivalent-stream-unread-char-test.tmp"))
+  (with-open-file (s pathname
+                     :element-type :default
+                     :direction :io :if-exists :rename)
+    (write-char #\a s)
+    (file-position s :start)
+    (unread-char (read-char s) s)
+    (assert (let ((buffer (make-array 10 :element-type '(unsigned-byte 8))))
+              (read-sequence buffer s))))
+  (delete-file pathname))
+
+#+sb-unicode
+(let ((pathname "bivalent-stream-unread-char-test.tmp"))
+  (with-open-file (s pathname
+                     :element-type :default
+                     :direction :io :if-exists :rename
+                     :external-format :utf8)
+    (write-char (code-char 192) s)
+    (file-position s :start)
+    (unread-char (read-char s) s)
+    (assert (integerp (read-byte s))))
+  (delete-file pathname))
+
+#+sb-unicode
+(let ((pathname "bivalent-stream-unread-char-test.tmp"))
+  (with-open-file (s pathname
+                     :element-type :default
+                     :direction :io :if-exists :rename
+                     :external-format :utf8)
+    (write-char (code-char 192) s)
+    (file-position s :start)
+    (unread-char (read-char s) s)
+    (assert (let ((buffer (make-array 10 :element-type '(unsigned-byte 8))))
+              (read-sequence buffer s))))
+  (delete-file pathname))
 
 ;;; success
diff --git a/version.lisp-expr b/version.lisp-expr
index 6cb587e..f6e89d5 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.27"
+"1.0.27.1"
-- 
1.7.10.4