[Sbcl-commits] CVS: sbcl/src/code stream.lisp, 1.109, 1.110 target-stream.lisp, 1.7, 1.8

[Richard M K. <kr...@us...>]

Update of /cvsroot/sbcl/sbcl/src/code
In directory fdv4jf1.ch3.sourceforge.com:/tmp/cvs-serv19898/src/code

Modified Files:
	stream.lisp target-stream.lisp 
Log Message:
1.0.27.18: Changes to ECHO-STREAMs

* Bugfix: PEEK-CHAR always popped the unread-stuff, leading to
  spurious duplicate echos in some cases.

* Minor incompatible change: UNREAD-CHAR on an ECHO-STREAM now unreads
  onto the echo-stream's input stream.  This is unspecified in the
  CLHS, but makes SBCL compatible with most implementations (AFAICT,
  everybody but CMUCL).

* Minor incompatible change: echo-streams used to buffer arbitrarily
  many characters in UNREAD-CHAR.  Conforming programs can't have
  relied on this, but non-conforming ones might have; users who need
  the old CMUCL/SBCL behavior can do it easily and de-facto-portably
  with Gray Streams.

* Possible bugfix that nobody cares about: ECHO-N-BIN (which
  implements a path through READ-SEQUENCE) can never have worked after
  an UNREAD-CHAR, because it tried to store characters into an octet
  buffer.


Index: stream.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/stream.lisp,v
retrieving revision 1.109
retrieving revision 1.110
diff -u -d -r1.109 -r1.110
--- stream.lisp	1 Jan 2009 20:50:41 -0000	1.109
+++ stream.lisp	22 Apr 2009 15:42:41 -0000	1.110
@@ -1081,7 +1081,7 @@
                       (n-bin #'echo-n-bin))
             (:constructor %make-echo-stream (input-stream output-stream))
             (:copier nil))
-  unread-stuff)
+  (unread-stuff nil :type boolean))
 (def!method print-object ((x echo-stream) stream)
   (print-unreadable-object (x stream :type t :identity t)
     (format stream
@@ -1106,47 +1106,55 @@
 
 (macrolet ((in-fun (name in-fun out-fun &rest args)
              `(defun ,name (stream ,@args)
-                (or (pop (echo-stream-unread-stuff stream))
-                    (let* ((in (echo-stream-input-stream stream))
-                           (out (echo-stream-output-stream stream))
-                           (result (if eof-error-p
-                                       (,in-fun in ,@args)
-                                       (,in-fun in nil in))))
-                      (cond
-                        ((eql result in) eof-value)
-                        (t (,out-fun result out) result)))))))
+                (let* ((unread-stuff-p (echo-stream-unread-stuff stream))
+                       (in (echo-stream-input-stream stream))
+                       (out (echo-stream-output-stream stream))
+                       (result (if eof-error-p
+                                   (,in-fun in ,@args)
+                                   (,in-fun in nil in))))
+                  (setf (echo-stream-unread-stuff stream) nil)
+                  (cond
+                    ((eql result in) eof-value)
+                    ;; If unread-stuff was true, the character read
+                    ;; from the input stream was previously echoed.
+                    (t (unless unread-stuff-p (,out-fun result out)) result))))))
   (in-fun echo-in read-char write-char eof-error-p eof-value)
   (in-fun echo-bin read-byte write-byte eof-error-p eof-value))
 
 (defun echo-n-bin (stream buffer start numbytes eof-error-p)
-  (let ((new-start start)
-        (read 0))
-    (loop
-     (let ((thing (pop (echo-stream-unread-stuff stream))))
-       (cond
-         (thing
-          (setf (aref buffer new-start) thing)
-          (incf new-start)
-          (incf read)
-          (when (= read numbytes)
-            (return-from echo-n-bin numbytes)))
-         (t (return nil)))))
-    (let ((bytes-read (read-n-bytes (echo-stream-input-stream stream) buffer
-                                    new-start (- numbytes read) nil)))
-      (cond
-        ((not eof-error-p)
-         (write-sequence buffer (echo-stream-output-stream stream)
-                         :start new-start :end (+ new-start bytes-read))
-         (+ bytes-read read))
-        ((> numbytes (+ read bytes-read))
-         (write-sequence buffer (echo-stream-output-stream stream)
-                         :start new-start :end (+ new-start bytes-read))
-         (error 'end-of-file :stream stream))
-        (t
-         (write-sequence buffer (echo-stream-output-stream stream)
-                         :start new-start :end (+ new-start bytes-read))
-         (aver (= numbytes (+ new-start bytes-read)))
-         numbytes)))))
+  (let ((bytes-read 0))
+    ;; Note: before ca 1.0.27.18, the logic for handling unread
+    ;; characters never could have worked, so probably nobody has ever
+    ;; tried doing bivalent block I/O through an echo stream; this may
+    ;; not work either.
+    (when (echo-stream-unread-stuff stream)
+      (let* ((char (read-char stream))
+             (octets (octets-to-string
+                      (string char)
+                      :external-format
+                      (stream-external-format
+                       (echo-stream-input-stream stream))))
+             (octet-count (length octets))
+             (blt-count (min octet-count numbytes)))
+        (replace buffer octets :start1 start :end1 (+ start blt-count))
+        (incf start blt-count)
+        (decf numbytes blt-count)))
+    (incf bytes-read (read-n-bytes (echo-stream-input-stream stream) buffer
+                                   start numbytes nil))
+    (cond
+      ((not eof-error-p)
+       (write-sequence buffer (echo-stream-output-stream stream)
+                       :start start :end (+ start bytes-read))
+       bytes-read)
+      ((> numbytes bytes-read)
+       (write-sequence buffer (echo-stream-output-stream stream)
+                       :start start :end (+ start bytes-read))
+       (error 'end-of-file :stream stream))
+      (t
+       (write-sequence buffer (echo-stream-output-stream stream)
+                       :start start :end (+ start bytes-read))
+       (aver (= numbytes (+ start bytes-read)))
+       numbytes))))
 
 ;;;; STRING-INPUT-STREAM stuff
 

Index: target-stream.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-stream.lisp,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- target-stream.lisp	10 Aug 2005 07:57:33 -0000	1.7
+++ target-stream.lisp	22 Apr 2009 15:42:41 -0000	1.8
@@ -109,13 +109,13 @@
          (out (two-way-stream-output-stream stream)))
     (case operation
       (:listen
-       (or (not (null (echo-stream-unread-stuff stream)))
-           (if (ansi-stream-p in)
-               (or (/= (the fixnum (ansi-stream-in-index in))
-                       +ansi-stream-in-buffer-length+)
-                   (funcall (ansi-stream-misc in) in :listen))
-               (stream-misc-dispatch in :listen))))
-      (:unread (push arg1 (echo-stream-unread-stuff stream)))
+       (if (ansi-stream-p in)
+           (or (/= (the fixnum (ansi-stream-in-index in))
+                   +ansi-stream-in-buffer-length+)
+               (funcall (ansi-stream-misc in) in :listen))
+           (stream-misc-dispatch in :listen)))
+      (:unread (setf (echo-stream-unread-stuff stream) t)
+               (unread-char arg1 in))
       (:element-type
        (let ((in-type (stream-element-type in))
              (out-type (stream-element-type out)))
@@ -133,26 +133,25 @@
        ;; echo-stream specific, or PEEK-CHAR because it is peeking code.
        ;; -- mrd 2002-11-18
        ;;
-       ;; UNREAD-CHAR-P indicates whether the current character was one
-       ;; that was previously unread.  In that case, we need to ensure that
-       ;; the semantics for UNREAD-CHAR are held; the character should
-       ;; not be echoed again.
-       (let ((unread-char-p nil))
+       ;; UNREAD-P indicates whether the next character on IN was one
+       ;; that was previously unread.  In that case, we need to ensure
+       ;; that the semantics for UNREAD-CHAR are held; the character
+       ;; should not be echoed again.
+       (let ((unread-p nil)
+             ;; The first peek shouldn't touch the unread-stuff slot.
+             (initial-peek-p t))
          (flet ((outfn (c)
-                  (unless unread-char-p
+                  (unless unread-p
                     (if (ansi-stream-p out)
                         (funcall (ansi-stream-out out) out c)
                         ;; gray-stream
                         (stream-write-char out c))))
                 (infn ()
-                  ;; Obtain input from unread buffer or input stream,
-                  ;; and set the flag appropriately.
-                  (cond ((not (null (echo-stream-unread-stuff stream)))
-                         (setf unread-char-p t)
-                         (pop (echo-stream-unread-stuff stream)))
-                        (t
-                         (setf unread-char-p nil)
-                         (read-char in (first arg2) :eof)))))
+                  (if initial-peek-p
+                      (setf unread-p (echo-stream-unread-stuff stream))
+                      (setf (echo-stream-unread-stuff stream) nil))
+                  (setf initial-peek-p nil)
+                  (read-char in (first arg2) :eof)))
            (generalized-peeking-mechanism
             arg1 (second arg2) char
             (infn)