From f3ea7a91cddd3ce35290ddd4e54abbe8a7a3a452 Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Mon, 11 Nov 2002 01:23:22 +0000 Subject: [PATCH] 0.7.9.39: merged MRD PEEK-CHAR-WRONGLY-ECHOS-TO-ECHO-STREAM patch... ...fixing Entomotomy bug of that name ...also converting EQ tests to EQL tests to be more robust under possibl efuture changes to CHARACTER representation --- NEWS | 3 ++ src/code/stream.lisp | 132 +++++++++++++++++++++++++++++++----------------- tests/stream.pure.lisp | 12 ++++- 3 files changed, 100 insertions(+), 47 deletions(-) diff --git a/NEWS b/NEWS index 427105c..2ab4ef4 100644 --- a/NEWS +++ b/NEWS @@ -1385,6 +1385,7 @@ changes in sbcl-0.7.10 relative to sbcl-0.7.9: is not a valid sequence index; ** LOOP signals (at macroexpansion time) an error of type PROGRAM-ERROR when duplicate variable names are found; + ** LOOP supports DOWNTO and ABOVE properly (thanks to Matthew Danish) ** FUNCALL of special-operators now cause an error of type UNDEFINED-FUNCTION; * fixed bug 166: compiler preserves "there is a way to go" @@ -1392,6 +1393,8 @@ changes in sbcl-0.7.10 relative to sbcl-0.7.9: * fixed bug 172: macro lambda lists with required arguments after &REST arguments now cause an error to be signalled. (thanks to Matthew Danish) + * fixed Entomotomy PEEK-CHAR-WRONGLY-ECHOS-TO-ECHO-STREAM bug (thanks + to Matthew Danish) planned incompatible changes in 0.7.x: * When the profiling interface settles down, maybe in 0.7.x, maybe diff --git a/src/code/stream.lisp b/src/code/stream.lisp index 29b8b21..807c422 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -255,6 +255,55 @@ (stream-unread-char stream character))) nil) + +;;; In the interest of ``once and only once'' this macro contains the +;;; framework necessary to implement a peek-char function, which has +;;; two special-cases (one for gray streams and one for echo streams) +;;; in addition to the normal case. +;;; +;;; All arguments are forms which will be used for a specific purpose +;;; PEEK-TYPE - the current peek-type as defined by ANSI CL +;;; EOF-VALUE - the eof-value argument to peek-char +;;; CHAR-VAR - the variable which will be used to store the current character +;;; READ-FORM - the form which will be used to read a character +;;; UNREAD-FORM - ditto for unread-char +;;; SKIPPED-CHAR-FORM - the form to execute when skipping a character +;;; EOF-DETECTED-FORM - the form to execute when EOF has been detected +;;; (this will default to CHAR-VAR) +(defmacro generalized-peeking-mechanism (peek-type eof-value char-var read-form unread-form &optional (skipped-char-form nil) (eof-detected-form nil)) + `(let ((,char-var ,read-form)) + (cond ((eql ,char-var ,eof-value) + ,(if eof-detected-form + eof-detected-form + char-var)) + ((characterp ,peek-type) + (do ((,char-var ,char-var ,read-form)) + ((or (eql ,char-var ,eof-value) + (char= ,char-var ,peek-type)) + (cond ((eql ,char-var ,eof-value) + ,(if eof-detected-form + eof-detected-form + char-var)) + (t ,unread-form + ,char-var))) + ,skipped-char-form)) + ((eql ,peek-type t) + (do ((,char-var ,char-var ,read-form)) + ((or (eql ,char-var ,eof-value) + (not (whitespace-char-p ,char-var))) + (cond ((eql ,char-var ,eof-value) + ,(if eof-detected-form + eof-detected-form + char-var)) + (t ,unread-form + ,char-var))) + ,skipped-char-form)) + ((null ,peek-type) + ,unread-form + ,char-var) + (t + (bug "Impossible case reached in PEEK-CHAR"))))) + (defun peek-char (&optional (peek-type nil) (stream *standard-input*) (eof-error-p t) @@ -273,52 +322,28 @@ :format-control "~@" :format-arguments (list peek-type '(or character boolean)))) (let ((stream (in-synonym-of stream))) - (if (ansi-stream-p stream) - (let ((char (read-char stream eof-error-p eof-value))) - (cond ((eq char eof-value) char) - ((characterp peek-type) - (do ((char char (read-char stream eof-error-p eof-value))) - ((or (eq char eof-value) (char= char peek-type)) - (unless (eq char eof-value) - (unread-char char stream)) - char))) - ((eq peek-type t) - (do ((char char (read-char stream eof-error-p eof-value))) - ((or (eq char eof-value) (not (whitespace-char-p char))) - (unless (eq char eof-value) - (unread-char char stream)) - char))) - ((null peek-type) - (unread-char char stream) - char) - (t - (bug "impossible case")))) - ;; by elimination, must be Gray streams FUNDAMENTAL-STREAM - (cond ((characterp peek-type) - (do ((char (stream-read-char stream) - (stream-read-char stream))) - ((or (eq char :eof) (char= char peek-type)) - (cond ((eq char :eof) - (eof-or-lose stream eof-error-p eof-value)) - (t - (stream-unread-char stream char) - char))))) - ((eq peek-type t) - (do ((char (stream-read-char stream) - (stream-read-char stream))) - ((or (eq char :eof) (not (whitespace-char-p char))) - (cond ((eq char :eof) - (eof-or-lose stream eof-error-p eof-value)) - (t - (stream-unread-char stream char) - char))))) - ((null peek-type) - (let ((char (stream-peek-char stream))) - (if (eq char :eof) - (eof-or-lose stream eof-error-p eof-value) - char))) - (t - (bug "impossible case")))))) + (cond ((typep stream 'echo-stream) + (echo-misc stream + :peek-char + peek-type + (list eof-error-p eof-value))) + ((ansi-stream-p stream) + (generalized-peeking-mechanism + peek-type eof-value char + (read-char stream eof-error-p eof-value) + (unread-char char stream))) + (t + ;; by elimination, must be Gray streams FUNDAMENTAL-STREAM + (generalized-peeking-mechanism + peek-type :eof char + (if (null peek-type) + (stream-peek-char stream) + (stream-read-char stream)) + (if (null peek-type) + () + (stream-unread-char stream char)) + () + (eof-or-lose stream eof-error-p eof-value)))))) (defun listen (&optional (stream *standard-input*)) (let ((stream (in-synonym-of stream))) @@ -971,6 +996,7 @@ (in-fun echo-bin read-byte ansi-stream-bout stream-write-byte eof-error-p eof-value)) + (defun echo-misc (stream operation &optional arg1 arg2) (let* ((in (two-way-stream-input-stream stream)) (out (two-way-stream-output-stream stream))) @@ -990,6 +1016,20 @@ in-type `(and ,in-type ,out-type)))) (:close (set-closed-flame stream)) + (:peek-char + ;; For the special case of peeking into an echo-stream + ;; arg1 is peek-type, arg2 is (eof-error-p eof-value) + ;; returns peeked-char, eof-value, or errors end-of-file + (flet ((outfn (c) + (if (ansi-stream-p out) + (funcall (ansi-stream-out out) out c) + ;; gray-stream + (stream-write-char out c)))) + (generalized-peeking-mechanism + arg1 (second arg2) char + (read-char in (first arg2) (second arg2)) + (unread-char char in) + (outfn char)))) (t (or (if (ansi-stream-p in) (funcall (ansi-stream-misc in) in operation arg1 arg2) diff --git a/tests/stream.pure.lisp b/tests/stream.pure.lisp index f62da09..845c87e 100644 --- a/tests/stream.pure.lisp +++ b/tests/stream.pure.lisp @@ -14,7 +14,7 @@ (in-package :cl-user) ;;; Until sbcl-0.6.11.31, we didn't have an N-BIN method for -;;; CONCATENATED-STRING, so stuff like this would fail. +;;; CONCATENATED-STREAM, so stuff like this would fail. (let ((stream (make-concatenated-stream (make-string-input-stream "Demo"))) (buffer (make-string 4))) (read-sequence buffer stream)) @@ -51,3 +51,13 @@ (unless (= n-actually-read-1 n-to-read) (assert (< n-actually-read-1 n-to-read)) (return))))) + +;;; Entomotomy PEEK-CHAR-WRONGLY-ECHOS-TO-ECHO-STREAM bug, fixed by +;;; by MRD patch sbcl-devel 2002-11-02 merged ca. sbcl-0.7.9.32 +(assert (string= + (with-output-to-string (out) + (peek-char #\] + (make-echo-stream + (make-string-input-stream "ab cd e df s]") out))) + ;; (Before the fix, the result had a trailing #\] in it.) + "ab cd e df s")) -- 1.7.10.4