From 68c539ab90bb39f342229e68bf9286f63824597a Mon Sep 17 00:00:00 2001 From: William Harold Newman Date: Sun, 7 Jan 2001 01:58:21 +0000 Subject: [PATCH] 0.6.9.20: MNA patch for bug #30 and other readtable-related stuff added tests for FIND and friends (anticipating new transforms) fixed dumb error-reporting bug in CANONIZED-DECL-SPEC --- BUGS | 5 - CREDITS | 7 +- NEWS | 7 +- src/code/reader.lisp | 278 +++++++++++++++++++++++-------------------- src/code/seq.lisp | 6 +- src/code/sharpm.lisp | 7 +- src/compiler/fndb.lisp | 74 +++++++----- src/compiler/proclaim.lisp | 2 +- src/compiler/srctran.lisp | 3 + tests/pathnames.impure.lisp | 1 - tests/reader.impure.lisp | 40 +++++++ tests/reader.pure.lisp | 16 +++ tests/seq.impure.lisp | 136 +++++++++++++++++++++ version.lisp-expr | 2 +- 14 files changed, 404 insertions(+), 180 deletions(-) create mode 100644 tests/reader.impure.lisp create mode 100644 tests/reader.pure.lisp create mode 100644 tests/seq.impure.lisp diff --git a/BUGS b/BUGS index a87dc33..25eaf5d 100644 --- a/BUGS +++ b/BUGS @@ -309,11 +309,6 @@ returning an array as first value always. The assertion (EQ (SB-C::CONTINUATION-KIND SB-C::CONT) :BLOCK-START) failed. This is still present in sbcl-0.6.8. -30: - The CMU CL reader code takes liberties in binding the standard read table - when reading the names of characters. Tim Moore posted a patch to the - CMU CL mailing list Mon, 22 May 2000 21:30:41 -0700. - 31: In some cases the compiler believes type declarations on array elements without checking them, e.g. diff --git a/CREDITS b/CREDITS index 10e9ad7..eeedcec 100644 --- a/CREDITS +++ b/CREDITS @@ -482,7 +482,9 @@ project's CVS change logs.) Martin Atzmueller: He reported many bugs, fixed many bugs, ported various fixes - from CMU CL, and helped clean up various stale bug data. + from CMU CL, and helped clean up various stale bug data. (He has + been unusually energetic at this. As of sbcl-0.6.9.10, the + total number of bugs involved likely exceeds 100.) Daniel Barlow: He contributed sblisp.lisp, a set of patches to make SBCL @@ -491,7 +493,7 @@ Daniel Barlow: with SBCL.) He also figured out how to get the CMU CL dynamic object file loading code to work under SBCL. -Cadabra, Inc.: +Cadabra, Inc. (later merged into GoTo.com): They hired William Newman to do some consulting for them, including the implementation of EQUALP hash tables for CMU CL; then agreed to release the EQUALP code into the public domain, @@ -531,4 +533,3 @@ Raymond Wiker: CMU CL support for FreeBSD and updating it for the changes made from FreeBSD version 3 to FreeBSD version 4. He also ported the CMU CL extension RUN-PROGRAM, and related code, to SBCL. - diff --git a/NEWS b/NEWS index b7bf019..df35d22 100644 --- a/NEWS +++ b/NEWS @@ -631,12 +631,13 @@ changes in sbcl-0.6.10 relative to sbcl-0.6.9: * Bug #17 (differing COMPILE-FILE behavior between logical and physical pathnames) has been fixed, and some related misbehavior too, thanks to a patch from Martin Atzmueller. -?? Martin Atzmueller fixed several filesystem-related problems, +* Bug #30 (reader problems) is gone, thanks to a CMU CL patch + by Tim Moore, ported to SBCL by Martin Atzmueller. +* Martin Atzmueller fixed several filesystem-related problems, including bug #36, in part by porting CMU CL patches, which were written in part by Paul Werkowski. -?? #'(SETF DOCUMENTATION) is now defined. * More compiler warnings in src/runtime/ are gone, thanks to - patches from Martin Atzmueller. + more patches from Martin Atzmueller. * Martin Atzmueller pointed out that bug 37 was fixed by his patches some time ago. diff --git a/src/code/reader.lisp b/src/code/reader.lisp index d4abe78..b8c6de2 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -11,10 +11,12 @@ (in-package "SB!IMPL") -;;; miscellaneous global variables +;;;; miscellaneous global variables -(defvar *read-default-float-format* 'single-float - #!+sb-doc "Float format for 1.0E1") +;;; ANSI: "the floating-point format that is to be used when reading a +;;; floating-point number that has no exponent marker or that has e or +;;; E for an exponent marker" +(defvar *read-default-float-format* 'single-float) (declaim (type (member short-float single-float double-float long-float) *read-default-float-format*)) @@ -55,6 +57,10 @@ ;;;; constants for character attributes. These are all as in the manual. +;;; FIXME: It's disturbing to bind nice names like ESCAPE and DELIMITER +;;; as constants throughout the entire SB-IMPL package. Perhaps these +;;; could be given some standard prefix, so instead we have constants +;;; CHATTR-ESCAPE and CHATTR-DELIMITER and so forth. (defconstant whitespace 0) (defconstant terminating-macro 1) (defconstant escape 2) @@ -67,8 +73,7 @@ ;; the "9" entry intentionally left blank for some reason -- WHN 19990806 (defconstant multiple-escape 10) (defconstant package-delimiter 11) -;; a fake attribute for use in read-unqualified-token -(defconstant delimiter 12) +(defconstant delimiter 12) ; (a fake for use in read-unqualified-token) ;;;; macros and functions for character tables @@ -111,20 +116,20 @@ (test-attribute char whitespace rt)) (defmacro constituentp (char &optional (rt '*readtable*)) - `(>= (get-cat-entry ,char ,rt) #.constituent)) + `(>= (get-cat-entry ,char ,rt) constituent)) (defmacro terminating-macrop (char &optional (rt '*readtable*)) - `(test-attribute ,char #.terminating-macro ,rt)) + `(test-attribute ,char terminating-macro ,rt)) (defmacro escapep (char &optional (rt '*readtable*)) - `(test-attribute ,char #.escape ,rt)) + `(test-attribute ,char escape ,rt)) (defmacro multiple-escape-p (char &optional (rt '*readtable*)) - `(test-attribute ,char #.multiple-escape ,rt)) + `(test-attribute ,char multiple-escape ,rt)) (defmacro token-delimiterp (char &optional (rt '*readtable*)) ;; depends on actual attribute numbering above. - `(<= (get-cat-entry ,char ,rt) #.terminating-macro)) + `(<= (get-cat-entry ,char ,rt) terminating-macro)) ;;;; secondary attribute table @@ -141,26 +146,26 @@ (defun !cold-init-secondary-attribute-table () (setq *secondary-attribute-table* (make-array char-code-limit :element-type '(unsigned-byte 8) - :initial-element #.constituent)) - (!set-secondary-attribute #\: #.package-delimiter) - (!set-secondary-attribute #\| #.multiple-escape) ; |) [for EMACS] - (!set-secondary-attribute #\. #.constituent-dot) - (!set-secondary-attribute #\+ #.constituent-sign) - (!set-secondary-attribute #\- #.constituent-sign) - (!set-secondary-attribute #\/ #.constituent-slash) + :initial-element constituent)) + (!set-secondary-attribute #\: package-delimiter) + (!set-secondary-attribute #\| multiple-escape) ; |) [for EMACS] + (!set-secondary-attribute #\. constituent-dot) + (!set-secondary-attribute #\+ constituent-sign) + (!set-secondary-attribute #\- constituent-sign) + (!set-secondary-attribute #\/ constituent-slash) (do ((i (char-code #\0) (1+ i))) ((> i (char-code #\9))) - (!set-secondary-attribute (code-char i) #.constituent-digit)) - (!set-secondary-attribute #\E #.constituent-expt) - (!set-secondary-attribute #\F #.constituent-expt) - (!set-secondary-attribute #\D #.constituent-expt) - (!set-secondary-attribute #\S #.constituent-expt) - (!set-secondary-attribute #\L #.constituent-expt) - (!set-secondary-attribute #\e #.constituent-expt) - (!set-secondary-attribute #\f #.constituent-expt) - (!set-secondary-attribute #\d #.constituent-expt) - (!set-secondary-attribute #\s #.constituent-expt) - (!set-secondary-attribute #\l #.constituent-expt)) + (!set-secondary-attribute (code-char i) constituent-digit)) + (!set-secondary-attribute #\E constituent-expt) + (!set-secondary-attribute #\F constituent-expt) + (!set-secondary-attribute #\D constituent-expt) + (!set-secondary-attribute #\S constituent-expt) + (!set-secondary-attribute #\L constituent-expt) + (!set-secondary-attribute #\e constituent-expt) + (!set-secondary-attribute #\f constituent-expt) + (!set-secondary-attribute #\d constituent-expt) + (!set-secondary-attribute #\s constituent-expt) + (!set-secondary-attribute #\l constituent-expt)) (defmacro get-secondary-attribute (char) `(elt *secondary-attribute-table* @@ -212,16 +217,16 @@ returns T." (if non-terminatingp (set-cat-entry char (get-secondary-attribute char) rt) - (set-cat-entry char #.terminating-macro rt)) + (set-cat-entry char terminating-macro rt)) (set-cmt-entry char function rt) T) -(defun get-macro-character (char &optional rt) +(defun get-macro-character (char &optional (rt *readtable*)) #!+sb-doc "Returns the function associated with the specified char which is a macro character. The optional readtable argument defaults to the current readtable." - (let ((rt (or rt *readtable*))) + (let ((rt (or rt *standard-readtable*))) ;; Check macro syntax, return associated function if it's there. ;; Returns a value for all constituents. (cond ((constituentp char) @@ -243,7 +248,7 @@ (do ((attribute-table (character-attribute-table *readtable*)) (char (fast-read-char t) (fast-read-char t))) ((/= (the fixnum (aref attribute-table (char-code char))) - #.whitespace) + whitespace) (done-with-fast-read-char) char))) ;; fundamental-stream @@ -251,7 +256,7 @@ (char (stream-read-char stream) (stream-read-char stream))) ((or (eq char :eof) (/= (the fixnum (aref attribute-table (char-code char))) - #.whitespace)) + whitespace)) (if (eq char :eof) (error 'end-of-file :stream stream) char)))))) @@ -263,14 +268,14 @@ ;; All characters default to "constituent" in MAKE-READTABLE. ;; *** un-constituent-ize some of these *** (let ((*readtable* *standard-readtable*)) - (set-cat-entry (code-char tab-char-code) #.whitespace) - (set-cat-entry #\linefeed #.whitespace) - (set-cat-entry #\space #.whitespace) - (set-cat-entry (code-char form-feed-char-code) #.whitespace) - (set-cat-entry (code-char return-char-code) #.whitespace) - (set-cat-entry #\\ #.escape) + (set-cat-entry (code-char tab-char-code) whitespace) + (set-cat-entry #\linefeed whitespace) + (set-cat-entry #\space whitespace) + (set-cat-entry (code-char form-feed-char-code) whitespace) + (set-cat-entry (code-char return-char-code) whitespace) + (set-cat-entry #\\ escape) (set-cmt-entry #\\ #'read-token) - (set-cat-entry (code-char rubout-char-code) #.whitespace) + (set-cat-entry (code-char rubout-char-code) whitespace) (set-cmt-entry #\: #'read-token) (set-cmt-entry #\| #'read-token) ;; macro definitions @@ -294,8 +299,9 @@ (defvar *read-buffer*) (defvar *read-buffer-length*) -;;; FIXME: Is it really helpful to have *READ-BUFFER-LENGTH* be a separate -;;; variable instead of just calculating it on the fly as (LENGTH *READ-BUFFER*)? +;;; FIXME: Is it really helpful to have *READ-BUFFER-LENGTH* be a +;;; separate variable instead of just calculating it on the fly as +;;; (LENGTH *READ-BUFFER*)? (defvar *inch-ptr*) (defvar *ouch-ptr*) @@ -304,12 +310,12 @@ (declaim (simple-string *read-buffer*)) (defmacro reset-read-buffer () - ;; Turn *read-buffer* into an empty read buffer. - ;; *Ouch-ptr* always points to next char to write. + ;; Turn *READ-BUFFER* into an empty read buffer. `(progn - (setq *ouch-ptr* 0) - ;; *inch-ptr* always points to next char to read. - (setq *inch-ptr* 0))) + ;; *OUCH-PTR* always points to next char to write. + (setq *ouch-ptr* 0) + ;; *INCH-PTR* always points to next char to read. + (setq *inch-ptr* 0))) (defun !cold-init-read-buffer () (setq *read-buffer* (make-string 512)) ; initial bufsize @@ -317,9 +323,10 @@ (reset-read-buffer)) ;;; FIXME I removed "THE FIXNUM"'s from OUCH-READ-BUFFER and -;;; OUCH-UNREAD-BUFFER, check to make sure that Python really is smart enough -;;; to make good code without them. And while I'm at it, converting them -;;; from macros to inline functions might be good, too. +;;; OUCH-UNREAD-BUFFER, check to make sure that Python really is smart +;;; enough to make good code without them. And while I'm at it, +;;; converting them from macros to inline functions might be good, +;;; too. (defmacro ouch-read-buffer (char) `(progn @@ -539,14 +546,18 @@ (declare (ignore ignore)) (%reader-error stream "unmatched close parenthesis")) -;;; Read from the stream up to the next delimiter. Leave the resulting token in -;;; *read-buffer*, and return two values: +;;; Read from the stream up to the next delimiter. Leave the resulting +;;; token in *READ-BUFFER*, and return two values: ;;; -- a list of the escaped character positions, and ;;; -- The position of the first package delimiter (or NIL). -(defun internal-read-extended-token (stream firstchar) +(defun internal-read-extended-token (stream firstchar escape-firstchar) (reset-read-buffer) + (let ((escapes '())) + (when escape-firstchar + (push *ouch-ptr* escapes) + (ouch-read-buffer firstchar) + (setq firstchar (read-char stream nil *eof-object*))) (do ((char firstchar (read-char stream nil *eof-object*)) - (escapes ()) (colon nil)) ((cond ((eofp char) t) ((token-delimiterp char) @@ -563,8 +574,8 @@ (reader-eof-error stream "after escape character") (ouch-read-buffer nextchar)))) ((multiple-escape-p char) - ;; Read to next multiple-escape, escaping single chars along the - ;; way. + ;; Read to next multiple-escape, escaping single chars + ;; along the way. (loop (let ((ch (read-char stream nil *eof-object*))) (cond @@ -573,18 +584,21 @@ ((multiple-escape-p ch) (return)) ((escapep ch) (let ((nextchar (read-char stream nil *eof-object*))) - (if (eofp nextchar) - (reader-eof-error stream "after escape character") - (ouch-read-buffer nextchar)))) + (cond ((eofp nextchar) + (reader-eof-error stream "after escape character")) + (t + (push *ouch-ptr* escapes) + (ouch-read-buffer nextchar))))) (t (push *ouch-ptr* escapes) (ouch-read-buffer ch)))))) (t (when (and (constituentp char) - (eql (get-secondary-attribute char) #.package-delimiter) + (eql (get-secondary-attribute char) + package-delimiter) (not colon)) (setq colon *ouch-ptr*)) - (ouch-read-buffer char))))) + (ouch-read-buffer char)))))) ;;;; character classes @@ -592,17 +606,17 @@ (defmacro char-class (char attable) `(let ((att (aref ,attable (char-code ,char)))) (declare (fixnum att)) - (if (<= att #.terminating-macro) - #.delimiter + (if (<= att terminating-macro) + delimiter att))) -;;; Return the character class for CHAR, which might be part of a rational -;;; number. +;;; Return the character class for CHAR, which might be part of a +;;; rational number. (defmacro char-class2 (char attable) `(let ((att (aref ,attable (char-code ,char)))) (declare (fixnum att)) - (if (<= att #.terminating-macro) - #.delimiter + (if (<= att terminating-macro) + delimiter (if (digit-char-p ,char *read-base*) constituent-digit (if (= att constituent-digit) @@ -622,8 +636,8 @@ (setq possibly-float (or (digit-char-p ,char 10) (= att constituent-dot)))) - (if (<= att #.terminating-macro) - #.delimiter + (if (<= att terminating-macro) + delimiter (if (digit-char-p ,char (max *read-base* 10)) (if (digit-char-p ,char *read-base*) constituent-digit @@ -688,15 +702,15 @@ (defun read-token (stream firstchar) #!+sb-doc "This function is just an fsm that recognizes numbers and symbols." - ;; Check explicitly whether firstchar has entry for non-terminating - ;; in character-attribute-table and read-dot-number-symbol in CMT. - ;; Report an error if these are violated (if we called this, we want - ;; something that is a legitimate token!). - ;; Read in the longest possible string satisfying the bnf for - ;; "unqualified-token". Leave the result in the *READ-BUFFER*. - ;; Return next char after token (last char read). + ;; Check explicitly whether FIRSTCHAR has an entry for + ;; NON-TERMINATING in CHARACTER-ATTRIBUTE-TABLE and + ;; READ-DOT-NUMBER-SYMBOL in CMT. Report an error if these are + ;; violated. (If we called this, we want something that is a + ;; legitimate token!) Read in the longest possible string satisfying + ;; the Backus-Naur form for "unqualified-token". Leave the result in + ;; the *READ-BUFFER*. Return next char after token (last char read). (when *read-suppress* - (internal-read-extended-token stream firstchar) + (internal-read-extended-token stream firstchar nil) (return-from read-token nil)) (let ((attribute-table (character-attribute-table *readtable*)) (package-designator nil) @@ -713,10 +727,9 @@ (#.escape (go ESCAPE)) (#.package-delimiter (go COLON)) (#.multiple-escape (go MULT-ESCAPE)) - ;;can't have eof, whitespace, or terminating macro as first char! + ;; can't have eof, whitespace, or terminating macro as first char! (t (go SYMBOL))) - SIGN - ;;saw "sign" + SIGN ; saw "sign" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) @@ -730,8 +743,7 @@ (#.multiple-escape (go MULT-ESCAPE)) (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) (t (go SYMBOL))) - LEFTDIGIT - ;;saw "[sign] {digit}+" + LEFTDIGIT ; saw "[sign] {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-integer))) @@ -749,8 +761,7 @@ (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) - MIDDLEDOT - ;;saw "[sign] {digit}+ dot" + MIDDLEDOT ; saw "[sign] {digit}+ dot" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (let ((*read-base* 10)) @@ -766,8 +777,7 @@ (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) - RIGHTDIGIT - ;;saw "[sign] {digit}* dot {digit}+" + RIGHTDIGIT ; saw "[sign] {digit}* dot {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-float))) @@ -779,8 +789,7 @@ (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) - SIGNDOT - ;;saw "[sign] dot" + SIGNDOT ; saw "[sign] dot" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) @@ -790,8 +799,7 @@ (#.escape (go ESCAPE)) (#.multiple-escape (go MULT-ESCAPE)) (t (go SYMBOL))) - FRONTDOT - ;;saw "dot" + FRONTDOT ; saw "dot" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (%reader-error stream "dot context error")) @@ -815,8 +823,7 @@ (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) - EXPTSIGN - ;;we got to EXPONENT, and saw a sign character. + EXPTSIGN ; got to EXPONENT, and saw a sign character (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) @@ -827,8 +834,7 @@ (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) - EXPTDIGIT - ;;got to EXPONENT, saw "[sign] {digit}+" + EXPTDIGIT ; got to EXPONENT, saw "[sign] {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-float))) @@ -839,8 +845,7 @@ (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) - RATIO - ;;saw "[sign] {digit}+ slash" + RATIO ; saw "[sign] {digit}+ slash" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) @@ -851,8 +856,7 @@ (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) - RATIODIGIT - ;;saw "[sign] {digit}+ slash {digit}+" + RATIODIGIT ; saw "[sign] {digit}+ slash {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-ratio))) @@ -863,8 +867,7 @@ (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) - DOTS - ;; saw "dot {dot}+" + DOTS ; saw "dot {dot}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (%reader-error stream "too many dots")) @@ -877,8 +880,7 @@ (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL))) - SYMBOL - ;; not a dot, dots, or number + SYMBOL ; not a dot, dots, or number (let ((stream (in-synonym-of stream))) (if (lisp-stream-p stream) (prepare-for-fast-read-char stream @@ -911,10 +913,9 @@ (#.multiple-escape (go MULT-ESCAPE)) (#.package-delimiter (go COLON)) (t (go SYMBOL-LOOP)))))) - ESCAPE - ;;saw an escape. - ;;don't put the escape in the read buffer. - ;;read-next char, put in buffer (no case conversion). + ESCAPE ; saw an escape + ;; Don't put the escape in the read buffer. + ;; READ-NEXT CHAR, put in buffer (no case conversion). (let ((nextchar (read-char stream nil nil))) (unless nextchar (reader-eof-error stream "after escape character")) @@ -1014,26 +1015,40 @@ "Symbol ~S not found in the ~A package."))) (return (intern name found))))))))) +;;; for semi-external use: +;;; +;;; For semi-external use: Return 3 values: the string for the token, +;;; a flag for whether there was an escape char, and the position of +;;; any package delimiter. (defun read-extended-token (stream &optional (*readtable* *readtable*)) - #!+sb-doc - "For semi-external use: returns 3 values: the string for the token, - a flag for whether there was an escape char, and the position of any - package delimiter." - (let ((firstch (read-char stream nil nil t))) - (cond (firstch + (let ((first-char (read-char stream nil nil t))) + (cond (first-char (multiple-value-bind (escapes colon) - (internal-read-extended-token stream firstch) + (internal-read-extended-token stream first-char nil) (casify-read-buffer escapes) (values (read-buffer-to-string) (not (null escapes)) colon))) (t (values "" nil nil))))) + +;;; for semi-external use: +;;; +;;; Read an extended token with the first character escaped. Return +;;; the string for the token. +(defun read-extended-token-escaped (stream &optional (*readtable* *readtable*)) + (let ((first-char (read-char stream nil nil))) + (cond (first-char + (let ((escapes (internal-read-extended-token stream first-char t))) + (casify-read-buffer escapes) + (read-buffer-to-string))) + (t + (reader-eof-error stream "after escape"))))) ;;;; number-reading functions (defmacro digit* nil `(do ((ch char (inch-read-buffer))) ((or (eofp ch) (not (digit-char-p ch))) (setq char ch)) - ;;report if at least one digit is seen: + ;; Report if at least one digit is seen. (setq one-digit t))) (defmacro exponent-letterp (letter) @@ -1172,6 +1187,12 @@ ;; appropriately. This should avoid any unnecessary ;; underflow or overflow problems. (multiple-value-bind (min-expo max-expo) + ;; FIXME: These #. forms are broken w.r.t. + ;; cross-compilation portability. Maybe expressions + ;; like + ;; (LOG SB!XC:MOST-POSITIVE-SHORT-FLOAT 10s0) + ;; could be used instead? Or perhaps some sort of + ;; load-time-form magic? (case float-format (short-float (values @@ -1199,7 +1220,9 @@ (setf number (/ number (expt 10 correction))) (setq num (make-float-aux number divisor float-format)) (setq num (* num (expt 10 exponent))) - (return-from make-float (if negative-fraction (- num) num)))))) + (return-from make-float (if negative-fraction + (- num) + num)))))) ;; should never happen: (t (error "internal error in floating point reader"))))) @@ -1207,7 +1230,7 @@ (coerce (/ number divisor) float-format)) (defun make-ratio () - ;; Assume *read-buffer* contains a legal ratio. Build the number from + ;; Assume *READ-BUFFER* contains a legal ratio. Build the number from ;; the string. ;; ;; Look for optional "+" or "-". @@ -1248,25 +1271,23 @@ (non-terminating-p nil) (rt *readtable*)) #!+sb-doc - "Causes char to become a dispatching macro character in readtable - (which defaults to the current readtable). If the non-terminating-p - flag is set to T, the char will be non-terminating. Make-dispatch- - macro-character returns T." + "Cause CHAR to become a dispatching macro character in readtable (which + defaults to the current readtable). If NON-TERMINATING-P, the char will + be non-terminating." (set-macro-character char #'read-dispatch-char non-terminating-p rt) (let* ((dalist (dispatch-tables rt)) (dtable (cdr (find char dalist :test #'char= :key #'car)))) (cond (dtable - (error "Dispatch character already exists.")) + (error "The dispatch character ~S already exists." char)) (t (setf (dispatch-tables rt) (push (cons char (make-char-dispatch-table)) dalist)))))) -(defun set-dispatch-macro-character - (disp-char sub-char function &optional (rt *readtable*)) +(defun set-dispatch-macro-character (disp-char sub-char function + &optional (rt *readtable*)) #!+sb-doc - "Causes function to be called whenever the reader reads - disp-char followed by sub-char. Set-dispatch-macro-character - returns T." + "Cause FUNCTION to be called whenever the reader reads DISP-CHAR + followed by SUB-CHAR." ;; Get the dispatch char for macro (error if not there), diddle ;; entry for sub-char. (when (digit-char-p sub-char) @@ -1280,13 +1301,14 @@ (coerce function 'function)) (error "~S is not a dispatch char." disp-char)))) -(defun get-dispatch-macro-character (disp-char sub-char &optional rt) +(defun get-dispatch-macro-character (disp-char sub-char + &optional (rt *readtable*)) #!+sb-doc "Returns the macro character function for sub-char under disp-char or nil if there is no associated function." (unless (digit-char-p sub-char) (let* ((sub-char (char-upcase sub-char)) - (rt (or rt *readtable*)) + (rt (or rt *standard-readtable*)) (dpair (find disp-char (dispatch-tables rt) :test #'char= :key #'car))) (if dpair diff --git a/src/code/seq.lisp b/src/code/seq.lisp index 2371a80..4292c35 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -1882,7 +1882,7 @@ `(vector-locater-macro ,sequence (locater-test-not ,item ,sequence :vector ,return-type) ,return-type)) - + (sb!xc:defmacro locater-if-test (test sequence seq-type return-type sense) (let ((seq-ref (case return-type (:position @@ -1909,7 +1909,7 @@ (sb!xc:defmacro vector-locater-if-not (test sequence return-type) `(vector-locater-if-macro ,test ,sequence ,return-type nil)) - + (sb!xc:defmacro list-locater-macro (sequence body-form return-type) `(if from-end (do ((sequence (nthcdr (- (the fixnum (length sequence)) @@ -1965,7 +1965,7 @@ ) ; EVAL-WHEN ;;; POSITION cannot default end to the length of sequence since it is not -;;; an error to supply nil for its value. We must test for end being nil +;;; an error to supply nil for its value. We must test for END being NIL ;;; in the body of the function, and this is actually done in the support ;;; routines for other reasons (see below). (defun position (item sequence &key from-end (test #'eql) test-not (start 0) diff --git a/src/code/sharpm.lisp b/src/code/sharpm.lisp index f172559..e03e1a3 100644 --- a/src/code/sharpm.lisp +++ b/src/code/sharpm.lisp @@ -300,17 +300,14 @@ (defun sharp-backslash (stream backslash numarg) (ignore-numarg backslash numarg) - (unread-char backslash stream) - (let* ((*readtable* *standard-readtable*) - (charstring (read-extended-token stream))) + (let ((charstring (read-extended-token-escaped stream))) (declare (simple-string charstring)) (cond (*read-suppress* nil) ((= (the fixnum (length charstring)) 1) (char charstring 0)) ((name-char charstring)) (t - (%reader-error stream - "unrecognized character name: ~S" + (%reader-error stream "unrecognized character name: ~S" charstring))))) (defun sharp-vertical-bar (stream sub-char numarg) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index 23e2d88..459a09e 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -184,7 +184,7 @@ (defknown make-package (stringable &key (:use list) (:nicknames list) - ;; ### Extensions... + ;; ### extensions... (:internal-symbols index) (:external-symbols index)) sb!xc:package) @@ -209,8 +209,10 @@ (defknown unintern (symbol &optional package-designator) boolean) (defknown unexport (symbols &optional package-designator) (eql t)) (defknown shadowing-import (symbols &optional package-designator) (eql t)) -(defknown shadow ((or symbol string list) &optional package-designator) (eql t)) -(defknown (use-package unuse-package) ((or list package-designator) &optional package-designator) (eql t)) +(defknown shadow ((or symbol string list) &optional package-designator) + (eql t)) +(defknown (use-package unuse-package) + ((or list package-designator) &optional package-designator) (eql t)) (defknown find-all-symbols (stringable) list (flushable)) ;;;; from the "Numbers" chapter: @@ -360,7 +362,8 @@ (defknown lognot (integer) integer (movable foldable flushable explicit-check)) (defknown logtest (integer integer) boolean (movable foldable flushable)) (defknown logbitp (bit-index integer) boolean (movable foldable flushable)) -(defknown ash (integer integer) integer (movable foldable flushable explicit-check)) +(defknown ash (integer integer) integer + (movable foldable flushable explicit-check)) (defknown (logcount integer-length) (integer) bit-index (movable foldable flushable explicit-check)) ;;; FIXME: According to the ANSI spec, it's legal to use any @@ -449,7 +452,8 @@ (flushable) :derive-type (result-type-specifier-nth-arg 1)) -(defknown (map %map) (type-specifier callable sequence &rest sequence) consed-sequence +(defknown (map %map) (type-specifier callable sequence &rest sequence) + consed-sequence (flushable call) ; :DERIVE-TYPE 'TYPE-SPEC-ARG1 ? Nope... (MAP NIL ...) returns NULL, not NIL. ) @@ -555,21 +559,22 @@ :derive-type (sequence-result-nth-arg 3)) (defknown remove-duplicates - (sequence &key (:test callable) (:test-not callable) (:start index) (:from-end t) - (:end sequence-end) (:key callable)) + (sequence &key (:test callable) (:test-not callable) (:start index) + (:from-end t) (:end sequence-end) (:key callable)) consed-sequence (flushable call) :derive-type (sequence-result-nth-arg 1)) (defknown delete-duplicates - (sequence &key (:test callable) (:test-not callable) (:start index) (:from-end t) - (:end sequence-end) (:key callable)) + (sequence &key (:test callable) (:test-not callable) (:start index) + (:from-end t) (:end sequence-end) (:key callable)) sequence (flushable call) :derive-type (sequence-result-nth-arg 1)) (defknown find (t sequence &key (:test callable) (:test-not callable) - (:start index) (:from-end t) (:end sequence-end) (:key callable)) + (:start index) (:from-end t) (:end sequence-end) + (:key callable)) t (foldable flushable call)) @@ -605,7 +610,8 @@ (defknown (mismatch search) (sequence sequence &key (:from-end t) (:test callable) (:test-not callable) - (:start1 index) (:end1 sequence-end) (:start2 index) (:end2 sequence-end) + (:start1 index) (:end1 sequence-end) + (:start2 index) (:end2 sequence-end) (:key callable)) (or index null) (foldable flushable call)) @@ -661,7 +667,8 @@ (defknown make-list (index &key (:initial-element t)) list (movable flushable unsafe)) -;;; All but last must be list... +;;; All but last must be of type LIST, but there seems to be no way to +;;; express that in this syntax.. (defknown append (&rest t) t (flushable)) (defknown copy-list (list) list (flushable)) @@ -700,17 +707,17 @@ list (foldable flushable unsafe call)) (defknown (union intersection set-difference set-exclusive-or) - (list list &key (:key callable) (:test callable) (:test-not callable)) + (list list &key (:key callable) (:test callable) (:test-not callable)) list (foldable flushable call)) (defknown (nunion nintersection nset-difference nset-exclusive-or) - (list list &key (:key callable) (:test callable) (:test-not callable)) + (list list &key (:key callable) (:test callable) (:test-not callable)) list (foldable flushable call)) (defknown subsetp - (list list &key (:key callable) (:test callable) (:test-not callable)) + (list list &key (:key callable) (:test callable) (:test-not callable)) boolean (foldable flushable call)) @@ -798,7 +805,8 @@ (foldable) #|:derive-type #'result-type-last-arg|#) -(defknown array-has-fill-pointer-p (array) boolean (movable foldable flushable)) +(defknown array-has-fill-pointer-p (array) boolean + (movable foldable flushable)) (defknown fill-pointer (vector) index (foldable flushable)) (defknown vector-push (t vector) (or index null) ()) (defknown vector-push-extend (t vector &optional index) index ()) @@ -876,22 +884,25 @@ (defknown make-concatenated-stream (&rest stream) stream (flushable)) (defknown make-two-way-stream (stream stream) stream (flushable)) (defknown make-echo-stream (stream stream) stream (flushable)) -(defknown make-string-input-stream (string &optional index index) stream (flushable unsafe)) +(defknown make-string-input-stream (string &optional index index) stream + (flushable unsafe)) (defknown make-string-output-stream () stream (flushable)) (defknown get-output-stream-string (stream) simple-string ()) (defknown streamp (t) boolean (movable foldable flushable)) -(defknown stream-element-type (stream) type-specifier (movable foldable flushable)) -(defknown (output-stream-p input-stream-p) (stream) boolean (movable foldable - flushable)) +(defknown stream-element-type (stream) type-specifier + (movable foldable flushable)) +(defknown (output-stream-p input-stream-p) (stream) boolean + (movable foldable flushable)) (defknown close (stream &key (:abort t)) stream ()) ;;;; from the "Input/Output" chapter: -;;; The I/O functions are currently given effects ANY under the theory -;;; that code motion over I/O operations is particularly confusing and -;;; not very important for efficency. +;;; (The I/O functions are given effects ANY under the theory that +;;; code motion over I/O operations is particularly confusing and not +;;; very important for efficiency.) -(defknown copy-readtable (&optional (or readtable null) readtable) readtable +(defknown copy-readtable (&optional (or readtable null) (or readtable null)) + readtable ()) (defknown readtablep (t) boolean (movable foldable flushable)) @@ -899,9 +910,10 @@ (character character &optional (or readtable null) readtable) (eql t) ()) -(defknown set-macro-character (character callable &optional t readtable) (eql t) +(defknown set-macro-character (character callable &optional t readtable) + (eql t) (unsafe)) -(defknown get-macro-character (character &optional readtable) +(defknown get-macro-character (character &optional (or readtable null)) (values callable boolean) (flushable)) (defknown make-dispatch-macro-character (character &optional t readtable) @@ -910,12 +922,12 @@ (character character callable &optional readtable) (eql t) (unsafe)) (defknown get-dispatch-macro-character - (character character &optional readtable) callable + (character character &optional (or readtable null)) callable (flushable)) ;;; may return any type due to eof-value... (defknown (read read-preserving-whitespace read-char-no-hang read-char) - (&optional streamlike t t t) t (explicit-check)) + (&optional streamlike t t t) t (explicit-check)) (defknown read-delimited-list (character &optional streamlike t) t (explicit-check)) @@ -1265,9 +1277,11 @@ (movable foldable flushable explicit-check)) (defknown %negate (number) number (movable foldable flushable explicit-check)) (defknown %check-bound (array index fixnum) index (movable foldable flushable)) -(defknown data-vector-ref (simple-array index) t (foldable flushable explicit-check)) +(defknown data-vector-ref (simple-array index) t + (foldable flushable explicit-check)) (defknown data-vector-set (array index t) t (unsafe explicit-check)) -(defknown hairy-data-vector-ref (array index) t (foldable flushable explicit-check)) +(defknown hairy-data-vector-ref (array index) t + (foldable flushable explicit-check)) (defknown hairy-data-vector-set (array index t) t (unsafe explicit-check)) (defknown sb!kernel:%caller-frame-and-pc () (values t t) (flushable)) (defknown sb!kernel:%with-array-data (array index (or index null)) diff --git a/src/compiler/proclaim.lisp b/src/compiler/proclaim.lisp index e2be4a2..5fe42b1 100644 --- a/src/compiler/proclaim.lisp +++ b/src/compiler/proclaim.lisp @@ -102,7 +102,7 @@ (defun canonized-decl-spec (decl-spec) (let ((id (first decl-spec))) (unless (symbolp id) - (error "The declaration identifier is not a symbol: ~S" what)) + (error "The declaration identifier is not a symbol: ~S" id)) (let ((id-is-type (info :type :kind id)) (id-is-declared-decl (info :declaration :recognized id))) (cond ((and id-is-type id-is-declared-decl) diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp index 121e1ee..931032f 100644 --- a/src/compiler/srctran.lisp +++ b/src/compiler/srctran.lisp @@ -2996,6 +2996,9 @@ ;;; Perhaps we should have to prove that the denominator is nonzero before ;;; doing them? (Also the DOLIST over macro calls is weird. Perhaps ;;; just FROB?) -- WHN 19990917 +;;; +;;; FIXME: What gives with the single quotes in the argument lists +;;; for DEFTRANSFORMs here? Does that work? Is it needed? Why? (dolist (name '(ash /)) (deftransform name ((x y) '((constant-argument (integer 0 0)) integer) '* :eval-name t :when :both) diff --git a/tests/pathnames.impure.lisp b/tests/pathnames.impure.lisp index e9867e8..51ceb80 100644 --- a/tests/pathnames.impure.lisp +++ b/tests/pathnames.impure.lisp @@ -126,4 +126,3 @@ ;;; success (quit :unix-status 104) -(in-package :cl-user) diff --git a/tests/reader.impure.lisp b/tests/reader.impure.lisp new file mode 100644 index 0000000..23ccb4c --- /dev/null +++ b/tests/reader.impure.lisp @@ -0,0 +1,40 @@ +;;;; tests related to the Lisp reader + +;;;; This file is impure because we want to modify the readtable and stuff. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(in-package :cl-user) + +;;; Bug 30, involving mistakes in binding the read table, made this +;;; code fail. +(defun read-vector (stream char) + (coerce (read-delimited-list #\] stream t) 'vector)) +(set-syntax-from-char #\[ #\() ; do I really need this? -- MNA 2001-01-05 +(set-syntax-from-char #\] #\)) ; do I really need this? -- MNA 2001-01-05 +(set-macro-character #\[ #'read-vector nil) +(set-macro-character #\] (get-macro-character #\)) nil) +(multiple-value-bind (res pos) + (read-from-string "[1 2 3]") ; ==> #(1 2 3), 7 + (assert (equalp res #(1 2 3))) + (assert (= pos 7))) +(multiple-value-bind (res pos) + (read-from-string "#\\x") ; ==> #\x, 3 + (assert (equalp res #\x)) + (assert (= pos 3))) +(multiple-value-bind (res pos) + (read-from-string "[#\\x]") + (assert (equalp res #(#\x))) + (assert (= pos 5))) + +;;; success +(quit :unix-status 104) diff --git a/tests/reader.pure.lisp b/tests/reader.pure.lisp new file mode 100644 index 0000000..acbb303 --- /dev/null +++ b/tests/reader.pure.lisp @@ -0,0 +1,16 @@ +;;;; tests related to the Lisp reader + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(in-package "CL-USER") + +(assert (equal (symbol-name '#:|fd\sA|) "fdsA")) diff --git a/tests/seq.impure.lisp b/tests/seq.impure.lisp new file mode 100644 index 0000000..d5fd7f4 --- /dev/null +++ b/tests/seq.impure.lisp @@ -0,0 +1,136 @@ +;;;; tests related to sequences + +;;;; This file is impure because we want to be able to use DEFUN. + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(in-package :cl-user) + +;;; helper functions for exercising SEQUENCE code on data of many +;;; specialized types, and in many different optimization scenarios +(defun for-every-seq-1 (base-seq snippet) + (dolist (seq-type '(list + (simple-array t 1) + (vector t) + (simple-array character 1) + (vector character) + (simple-array (signed-byte 4) 1) + (vector (signed-byte 4)))) + (flet ((entirely (eltype) + (every (lambda (el) (typep el eltype)) base-seq))) + (dolist (declaredness '(nil t)) + (dolist (optimization '(((speed 3) (space 0)) + ((speed 2) (space 2)) + ((speed 1) (space 2)) + ((speed 0) (space 1)))) + (let* ((seq (if (eq seq-type 'list) + (coerce base-seq 'list) + (destructuring-bind (type-first &rest type-rest) + seq-type + (ecase type-first + (simple-array + (destructuring-bind (eltype one) type-rest + (assert (= one 1)) + (if (entirely eltype) + (coerce base-seq seq-type) + (return)))) + (vector + (destructuring-bind (eltype) type-rest + (if (entirely eltype) + (replace (make-array (length base-seq) + :element-type eltype + :adjustable t) + base-seq) + (return)))))))) + (lambda-expr `(lambda (seq) + ,@(when declaredness + `((declare (type ,seq-type seq)))) + (declare (optimize ,@optimization)) + ,snippet))) + (multiple-value-bind (fun warnings-p failure-p) + (compile nil lambda-expr) + (when (or warnings-p failure-p) + (error "~@" lambda-expr)) + (unless (funcall fun seq) + (error "~@" + base-seq + snippet + seq-type + declaredness + optimization))))))))) +(defun for-every-seq (base-seq snippets) + (dolist (snippet snippets) + (for-every-seq-1 base-seq snippet))) + +;;; tests of FIND, POSITION, FIND-IF, and POSITION-IF (and a few for +;;; deprecated FIND-IF-NOT and POSITION-IF-NOT too) +(for-every-seq #() + '((null (find 1 seq)) + (null (find 1 seq :from-end t)) + (null (position 1 seq :key #'abs)) + (null (position nil seq :test (constantly t))) + (null (position nil seq :test nil)) + (null (position nil seq :test-not nil)) + (null (find-if #'1+ seq :key #'log)) + (null (position-if #'identity seq :from-end t)) + (null (find-if-not #'packagep seq)) + (null (position-if-not #'packagep seq :key nil)))) +(for-every-seq #(1) + '((null (find 2 seq)) + (find 2 seq :key #'1+) + (find 1 seq :from-end t) + (null (find 0 seq :from-end t)) + (eql 0 (position 1 seq :key #'abs)) + (null (position nil seq :test 'equal)) + (eql 1 (find-if #'1- seq :key #'log)) + (eql 0 (position-if #'identity seq :from-end t)) + (null (find-if-not #'sin seq)) + (eql 0 (position-if-not #'packagep seq :key 'identity)))) +(for-every-seq #(1 2 3 2 1) + '((find 3 seq) + (find 3 seq :from-end 'yes) + (eql 0 (position 0 seq :key '1-)) + (eql 4 (position 0 seq :key '1- :from-end t)) + (eql 2 (position 4 seq :key '1+)) + (eql 2 (position 4 seq :key '1+ :from-end t)) + (eql 1 (position 2 seq)) + (eql 3 (position 2 seq :key nil :from-end t)) + (eql 2 (position 3 seq :test '=)) + (eql 0 (position 3 seq :test-not 'equalp)) + (eql 2 (position 3 seq :test 'equal :from-end t)) + (null (position 4 seq :test #'eql)) + (null (find-if #'packagep seq)) + (eql 1 (find-if #'plusp seq)) + (eql 3 (position-if #'plusp seq :key #'1- :from-end t)) + (eql 1 (position-if #'evenp seq)) + (eql 3 (position-if #'evenp seq :from-end t)) + (null (find-if-not #'plusp seq)) + (eql 0 (position-if-not #'evenp seq)))) +(for-every-seq "string test" + '((null (find 0 seq)) + (null (find #\D seq :key #'char-upcase)) + (find #\E seq :key #'char-upcase) + (null (find #\e seq :key #'char-upcase)) + (eql 3 (position #\i seq)) + (eql 0 (position #\s seq :key #'char-downcase)) + (eql 1 (position #\s seq :key #'char-downcase :test #'char/=)) + (eql 9 (position #\s seq :from-end t :test #'char=)) + (eql 10 (position #\s seq :from-end t :test #'char/=)) + (eql 4 (position #\N seq :from-end t :key 'char-upcase :test #'char-equal)) + (eql 5 (position-if (lambda (c) (equal #\g c)) seq)) + (eql 5 (position-if (lambda (c) (equal #\g c)) seq :from-end t)) + (find-if #'characterp seq) + (find-if #'(lambda (c) (typep c 'base-char)) seq :from-end t) + (null (find-if 'upper-case-p seq)))) + +;;; success +(quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index b5277ed..2fe4feb 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -15,4 +15,4 @@ ;;; versions, and a string like "0.6.5.12" is used for versions which ;;; aren't released but correspond only to CVS tags or snapshots. -"0.6.9.19" +"0.6.9.20" -- 1.7.10.4