From c47519c9e63fd32a635943a84ec13d8a60d95f08 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Tue, 20 Jan 2004 18:10:22 +0000 Subject: [PATCH] 0.8.7.19: Fix for PEEK-CHAR: whitespace means "according to the readtable", not "static list of characters" ... but that's complicated for efficiency: we need WHITESPACEP defined before peek-char so that it can be expanded inline ... so move peek-charish things into a new later file ... delete unused-by-core WHITESPACE-CHAR-P, and adjust contribs to accomodate this ... also add #\page to sb-aclrepl's static whitespace characters --- NEWS | 2 + build-order.lisp-expr | 1 + contrib/sb-aclrepl/repl.lisp | 3 +- contrib/sb-simple-streams/impl.lisp | 6 +- src/code/stream.lisp | 142 ------------------------------ src/code/target-char.lisp | 7 -- src/code/target-extensions.lisp | 9 +- src/code/target-stream.lisp | 162 +++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 9 files changed, 172 insertions(+), 162 deletions(-) create mode 100644 src/code/target-stream.lisp diff --git a/NEWS b/NEWS index 3ca21d1..8be61c1 100644 --- a/NEWS +++ b/NEWS @@ -2258,6 +2258,8 @@ changes in sbcl-0.8.8 relative to sbcl-0.8.7: host is already defined. ** RENAME-FILE works on streams instead of signalling an internal type error. + ** PEEK-CHAR now uses the current readtable when determining + whether a character is whitespace. planned incompatible changes in 0.8.x: * (not done yet, but planned:) When the profiling interface settles diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 4214e69..4af8283 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -613,6 +613,7 @@ ("src/code/target-random" :not-host) ; needs "code/random" ("src/code/target-hash-table" :not-host) ; needs "code/hash-table" ("src/code/reader" :not-host) ; needs "code/readtable" + ("src/code/target-stream" :not-host) ; needs WHITESPACEP from "code/reader" ("src/code/target-pathname" :not-host) ; needs "code/pathname" ("src/code/filesys" :not-host) ; needs HOST from "code/pathname" ("src/code/save" :not-host) ; uses the definition of PATHNAME diff --git a/contrib/sb-aclrepl/repl.lisp b/contrib/sb-aclrepl/repl.lisp index defbc32..800d9b3 100644 --- a/contrib/sb-aclrepl/repl.lisp +++ b/contrib/sb-aclrepl/repl.lisp @@ -760,17 +760,16 @@ (and (characterp x) (or (char= x #\space) (char= x #\tab) + (char= x #\page) (char= x #\newline) (char= x #\return)))) (defun whitespace-char-not-newline-p (x) (and (whitespace-char-p x) (not (char= x #\newline)))) - ;;;; linking into SBCL hooks - (defun repl-prompt-fun (stream) (let ((break-level (when (plusp *break-level*) *break-level*)) diff --git a/contrib/sb-simple-streams/impl.lisp b/contrib/sb-simple-streams/impl.lisp index 2657fb1..a8adfa0 100644 --- a/contrib/sb-simple-streams/impl.lisp +++ b/contrib/sb-simple-streams/impl.lisp @@ -953,6 +953,8 @@ (etypecase stream (simple-stream (%peek-char stream peek-type eof-error-p eof-value recursive-p)) + ;; FIXME: Broken on ECHO-STREAM (cf internal implementation?) -- + ;; CSR, 2004-01-19 (ansi-stream (let ((char (%ansi-stream-read-char stream eof-error-p eof-value t))) (cond ((eq char eof-value) char) @@ -967,7 +969,7 @@ (do ((char char (%ansi-stream-read-char stream eof-error-p eof-value t))) ((or (eq char eof-value) - (not (sb-int:whitespace-char-p char))) + (not (sb-impl::whitespacep char))) (unless (eq char eof-value) (%ansi-stream-unread-char char stream)) char))) @@ -987,7 +989,7 @@ ((eq peek-type t) (do ((char (sb-gray:stream-read-char stream) (sb-gray:stream-read-char stream))) - ((or (eq char :eof) (not (sb-int:whitespace-char-p char))) + ((or (eq char :eof) (not (sb-impl::whitespacep char))) (cond ((eq char :eof) (sb-impl::eof-or-lose stream eof-error-p eof-value)) (t diff --git a/src/code/stream.lisp b/src/code/stream.lisp index f39c4f5..63b3fa3 100644 --- a/src/code/stream.lisp +++ b/src/code/stream.lisp @@ -277,86 +277,6 @@ (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) - eof-value - recursive-p) - (declare (ignore recursive-p)) - (the (or character boolean) peek-type) - (let ((stream (in-synonym-of stream))) - (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))) (if (ansi-stream-p stream) @@ -1005,68 +925,6 @@ 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-misc (stream operation &optional arg1 arg2) - (let* ((in (two-way-stream-input-stream stream)) - (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))) - (:element-type - (let ((in-type (stream-element-type in)) - (out-type (stream-element-type out))) - (if (equal in-type out-type) - 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 - ;; - ;; Note: This code could be moved into PEEK-CHAR if desired. - ;; I am unsure whether this belongs with echo-streams because it is - ;; 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)) - (flet ((outfn (c) - (unless unread-char-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) (second arg2)))))) - (generalized-peeking-mechanism - arg1 (second arg2) char - (infn) - (unread-char char in) - (outfn char))))) - (t - (or (if (ansi-stream-p in) - (funcall (ansi-stream-misc in) in operation arg1 arg2) - (stream-misc-dispatch in operation arg1 arg2)) - (if (ansi-stream-p out) - (funcall (ansi-stream-misc out) out operation arg1 arg2) - (stream-misc-dispatch out operation arg1 arg2))))))) ;;;; base STRING-STREAM stuff diff --git a/src/code/target-char.lisp b/src/code/target-char.lisp index 4be9e83..161d893 100644 --- a/src/code/target-char.lisp +++ b/src/code/target-char.lisp @@ -210,13 +210,6 @@ ;; Else, fail. (t nil)))) -(defun whitespace-char-p (x) - (and (characterp x) - (or (char= x #\space) - (char= x (code-char tab-char-code)) - (char= x (code-char return-char-code)) - (char= x #\linefeed)))) - (defun alphanumericp (char) #!+sb-doc "Given a character-object argument, ALPHANUMERICP returns T if the diff --git a/src/code/target-extensions.lisp b/src/code/target-extensions.lisp index 7b13df4..cbaab4d 100644 --- a/src/code/target-extensions.lisp +++ b/src/code/target-extensions.lisp @@ -35,19 +35,12 @@ up. The system itself should be initialized at this point, but applications might not be.") -;;;; miscellaneous I/O - -(defun skip-whitespace (&optional (stream *standard-input*)) - (loop (let ((char (read-char stream))) - (unless (sb!impl::whitespacep char) - (return (unread-char char stream)))))) - ;;; like LISTEN, but any whitespace in the input stream will be flushed (defun listen-skip-whitespace (&optional (stream *standard-input*)) (do ((char (read-char-no-hang stream nil nil nil) (read-char-no-hang stream nil nil nil))) ((null char) nil) - (cond ((not (whitespace-char-p char)) + (cond ((not (whitespacep char)) (unread-char char stream) (return t))))) diff --git a/src/code/target-stream.lisp b/src/code/target-stream.lisp new file mode 100644 index 0000000..4b254f6 --- /dev/null +++ b/src/code/target-stream.lisp @@ -0,0 +1,162 @@ +;;;; os-independent stream functions requiring reader machinery + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; This software is derived from the CMU CL system, which was +;;;; written at Carnegie Mellon University and released into the +;;;; public domain. The software is in the public domain and is +;;;; provided with absolutely no warranty. See the COPYING and CREDITS +;;;; files for more information. + +(in-package "SB!IMPL") + +;;; 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) +(eval-when (:compile-toplevel :execute) + (sb!xc: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 (whitespacep ,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")))))) + +;;; We proclaim them INLINE here, then proclaim them MAYBE-INLINE at EOF, +;;; so, except in this file, they are not inline by default, but they can be. +#!-sb-fluid (declaim (inline read-char unread-char read-byte listen)) + +(defun peek-char (&optional (peek-type nil) + (stream *standard-input*) + (eof-error-p t) + eof-value + recursive-p) + (declare (ignore recursive-p)) + (the (or character boolean) peek-type) + (let ((stream (in-synonym-of stream))) + (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 echo-misc (stream operation &optional arg1 arg2) + (let* ((in (two-way-stream-input-stream stream)) + (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))) + (:element-type + (let ((in-type (stream-element-type in)) + (out-type (stream-element-type out))) + (if (equal in-type out-type) + 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 + ;; + ;; Note: This code could be moved into PEEK-CHAR if desired. + ;; I am unsure whether this belongs with echo-streams because it is + ;; 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)) + (flet ((outfn (c) + (unless unread-char-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) (second arg2)))))) + (generalized-peeking-mechanism + arg1 (second arg2) char + (infn) + (unread-char char in) + (outfn char))))) + (t + (or (if (ansi-stream-p in) + (funcall (ansi-stream-misc in) in operation arg1 arg2) + (stream-misc-dispatch in operation arg1 arg2)) + (if (ansi-stream-p out) + (funcall (ansi-stream-misc out) out operation arg1 arg2) + (stream-misc-dispatch out operation arg1 arg2))))))) + +(declaim (maybe-inline read-char unread-char read-byte listen)) \ No newline at end of file diff --git a/version.lisp-expr b/version.lisp-expr index 3979734..305174d 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".) -"0.8.7.18" +"0.8.7.19" -- 1.7.10.4