From: Richard M Kreuter Date: Wed, 22 Apr 2009 15:42:41 +0000 (+0000) Subject: 1.0.27.18: Changes to ECHO-STREAMs X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=76f3e23c8ad6f98d60ff97233e11082a41faf894;p=sbcl.git 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. --- diff --git a/NEWS b/NEWS index 6dc7d63..92cdbf8 100644 --- a/NEWS +++ b/NEWS @@ -8,6 +8,9 @@ changes in sbcl-1.0.28 relative to 1.0.27: * improvement: on x86/x86-64 Lisp call frames now have the same layout as C frames, allowing for instance more reliable backtraces. * optimization: faster local calls on x86/x86-64 + * minor incompatible changes: echo-streams now propagate unread-char to the + underlying input stream, and no longer permit unreading more than one + character. changes in sbcl-1.0.27 relative to 1.0.26: * new port: support added for x86-64 OpenBSD. (thanks to Josh Elsasser) diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 74331be..e795f01 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -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 diff --git a/src/code/target-stream.lisp b/src/code/target-stream.lisp index c18b851..3cc60e6 100644 --- a/src/code/target-stream.lisp +++ b/src/code/target-stream.lisp @@ -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) diff --git a/tests/stream.pure.lisp b/tests/stream.pure.lisp index b35c61e..f0f9a24 100644 --- a/tests/stream.pure.lisp +++ b/tests/stream.pure.lisp @@ -73,6 +73,19 @@ (get-output-stream-string out-stream)) ;; (Before the fix, the LET* expression just signalled an error.) "a")) +;;; ... and yet, a little over 6 years on, echo-streams were still +;;; broken when a read-char followed the unread/peek sequence. Do +;;; people not actually use echo-streams? RMK, 2009-04-02. +(assert (string= + (let* ((in-stream (make-string-input-stream "abc")) + (out-stream (make-string-output-stream)) + (echo-stream (make-echo-stream in-stream out-stream))) + (unread-char (read-char echo-stream) echo-stream) + (peek-char nil echo-stream) + (read-char echo-stream) + (get-output-stream-string out-stream)) + ;; before ca. 1.0.27.18, the LET* returned "aa" + "a")) ;;; Reported by Fredrik Sandstrom to sbcl-devel 2005-05-17 ("Bug in ;;; peek-char"): @@ -337,3 +350,22 @@ (let ((v (make-array 5 :fill-pointer 0 :element-type 'standard-char))) (format v "foo") (assert (equal (coerce "foo" 'base-string) v)))) + +;;; Circa 1.0.27.18, echo-streams were changed somewhat, so that +;;; unread-char on an echo-stream propagated the character down to the +;;; echo-stream's input stream. (All other implementations but CMUCL +;;; seemed to do this). The most useful argument for this behavior +;;; involves cases where an input operation on an echo-stream finishes +;;; up by unreading a delimiter, and the user wants to proceed to use the +;;; underlying stream, e.g., +(assert (equal + (with-input-from-string (in "foo\"bar\"") + (with-open-stream (out (make-broadcast-stream)) + (with-open-stream (echo (make-echo-stream in out)) + (read echo))) + (read in)) + ;; Before ca 1.0.27.18, the implicit UNREAD-CHAR at the end of + ;; the first READ wouldn't get back to IN, so the second READ + ;; returned BAR, not "BAR" (and then subsequent reads would + ;; lose). + "bar")) diff --git a/version.lisp-expr b/version.lisp-expr index 7799e91..2a4f2d0 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.17" +"1.0.27.18"