X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Freader.lisp;h=7fc9cd1b832b9d7b3c71cd427a5fdc596ee524f4;hb=abecd31762c38b078077ebbfbadb51139dee6059;hp=d4abe789389c09f2dcb5b36fce92e06fe7d8ccec;hpb=02ce4b1b927f1312c300047bd5a0db6663a1d2c6;p=sbcl.git diff --git a/src/code/reader.lisp b/src/code/reader.lisp index d4abe78..7fc9cd1 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*)) @@ -53,23 +55,6 @@ :format-control control :format-arguments args)) -;;;; constants for character attributes. These are all as in the manual. - -(defconstant whitespace 0) -(defconstant terminating-macro 1) -(defconstant escape 2) -(defconstant constituent 3) -(defconstant constituent-dot 4) -(defconstant constituent-expt 5) -(defconstant constituent-slash 6) -(defconstant constituent-digit 7) -(defconstant constituent-sign 8) -;; 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) - ;;;; macros and functions for character tables ;;; FIXME: could be SB!XC:DEFMACRO inside EVAL-WHEN (COMPILE EVAL) @@ -84,16 +69,28 @@ (char-code char)) newvalue)) -;;; FIXME: could be SB!XC:DEFMACRO inside EVAL-WHEN (COMPILE EVAL) -(defmacro get-cmt-entry (char rt) - `(the function - (elt (the simple-vector (character-macro-table ,rt)) - (char-code ,char)))) - -(defun set-cmt-entry (char newvalue &optional (rt *readtable*)) - (setf (elt (the simple-vector (character-macro-table rt)) - (char-code char)) - (coerce newvalue 'function))) +;;; the value actually stored in the character macro table. As per +;;; ANSI #'GET-MACRO-CHARACTER and #'SET-MACRO-CHARACTER, this can +;;; be either a function or NIL. +(eval-when (:compile-toplevel :execute) + (sb!xc:defmacro get-raw-cmt-entry (char readtable) + `(svref (character-macro-table ,readtable) + (char-code ,char)))) + +;;; the value represented by whatever is stored in the character macro +;;; table. As per ANSI #'GET-MACRO-CHARACTER and #'SET-MACRO-CHARACTER, +;;; a function value represents itself, and a NIL value represents the +;;; default behavior. +(defun get-coerced-cmt-entry (char readtable) + (the function + (or (get-raw-cmt-entry char readtable) + #'read-token))) + +(defun set-cmt-entry (char new-value-designator &optional (rt *readtable*)) + (setf (svref (character-macro-table rt) + (char-code char)) + (and new-value-designator + (%coerce-callable-to-fun new-value-designator)))) (defun undefined-macro-char (stream char) (unless *read-suppress* @@ -108,28 +105,28 @@ #!-sb-fluid (declaim (inline whitespacep)) (defun whitespacep (char &optional (rt *readtable*)) - (test-attribute char whitespace rt)) + (test-attribute char +char-attr-whitespace+ rt)) (defmacro constituentp (char &optional (rt '*readtable*)) - `(>= (get-cat-entry ,char ,rt) #.constituent)) + `(>= (get-cat-entry ,char ,rt) +char-attr-constituent+)) (defmacro terminating-macrop (char &optional (rt '*readtable*)) - `(test-attribute ,char #.terminating-macro ,rt)) + `(test-attribute ,char +char-attr-terminating-macro+ ,rt)) (defmacro escapep (char &optional (rt '*readtable*)) - `(test-attribute ,char #.escape ,rt)) + `(test-attribute ,char +char-attr-escape+ ,rt)) (defmacro multiple-escape-p (char &optional (rt '*readtable*)) - `(test-attribute ,char #.multiple-escape ,rt)) + `(test-attribute ,char +char-attr-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) +char-attr-terminating-macro+)) ;;;; secondary attribute table -;;; There are a number of "secondary" attributes which are constant properties -;;; of characters (as long as they are constituents). +;;; There are a number of "secondary" attributes which are constant +;;; properties of characters (as long as they are constituents). (defvar *secondary-attribute-table*) (declaim (type attribute-table *secondary-attribute-table*)) @@ -141,26 +138,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 +char-attr-constituent+)) + (!set-secondary-attribute #\: +char-attr-package-delimiter+) + (!set-secondary-attribute #\| +char-attr-multiple-escape+) ; |) [for EMACS] + (!set-secondary-attribute #\. +char-attr-constituent-dot+) + (!set-secondary-attribute #\+ +char-attr-constituent-sign+) + (!set-secondary-attribute #\- +char-attr-constituent-sign+) + (!set-secondary-attribute #\/ +char-attr-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) +char-attr-constituent-digit+)) + (!set-secondary-attribute #\E +char-attr-constituent-expt+) + (!set-secondary-attribute #\F +char-attr-constituent-expt+) + (!set-secondary-attribute #\D +char-attr-constituent-expt+) + (!set-secondary-attribute #\S +char-attr-constituent-expt+) + (!set-secondary-attribute #\L +char-attr-constituent-expt+) + (!set-secondary-attribute #\e +char-attr-constituent-expt+) + (!set-secondary-attribute #\f +char-attr-constituent-expt+) + (!set-secondary-attribute #\d +char-attr-constituent-expt+) + (!set-secondary-attribute #\s +char-attr-constituent-expt+) + (!set-secondary-attribute #\l +char-attr-constituent-expt+)) (defmacro get-secondary-attribute (char) `(elt *secondary-attribute-table* @@ -169,17 +166,20 @@ ;;;; readtable operations (defun copy-readtable (&optional (from-readtable *readtable*) - (to-readtable (make-readtable))) - (let ((really-from-readtable (or from-readtable *standard-readtable*))) - (replace (character-attribute-table to-readtable) + to-readtable) + (let ((really-from-readtable (or from-readtable *standard-readtable*)) + (really-to-readtable (or to-readtable (make-readtable)))) + (replace (character-attribute-table really-to-readtable) (character-attribute-table really-from-readtable)) - (replace (character-macro-table to-readtable) + (replace (character-macro-table really-to-readtable) (character-macro-table really-from-readtable)) - (setf (dispatch-tables to-readtable) - (mapcar #'(lambda (pair) (cons (car pair) - (copy-seq (cdr pair)))) + (setf (dispatch-tables really-to-readtable) + (mapcar (lambda (pair) (cons (car pair) + (copy-seq (cdr pair)))) (dispatch-tables really-from-readtable))) - to-readtable)) + (setf (readtable-case really-to-readtable) + (readtable-case really-from-readtable)) + really-to-readtable)) (defun set-syntax-from-char (to-char from-char &optional (to-readtable *readtable*) @@ -189,8 +189,8 @@ optional readtable (defaults to the current readtable). The FROM-TABLE defaults to the standard Lisp readtable when NIL." (let ((really-from-readtable (or from-readtable *standard-readtable*))) - ;; Copy from-char entries to to-char entries, but make sure that if - ;; from char is a constituent you don't copy non-movable secondary + ;; Copy FROM-CHAR entries to TO-CHAR entries, but make sure that if + ;; FROM-CHAR is a constituent you don't copy non-movable secondary ;; attributes (constituent types), and that said attributes magically ;; appear if you transform a non-constituent to a constituent. (let ((att (get-cat-entry from-char really-from-readtable))) @@ -198,60 +198,70 @@ (setq att (get-secondary-attribute to-char))) (set-cat-entry to-char att to-readtable) (set-cmt-entry to-char - (get-cmt-entry from-char really-from-readtable) + (get-raw-cmt-entry from-char really-from-readtable) to-readtable))) t) (defun set-macro-character (char function &optional - (non-terminatingp nil) (rt *readtable*)) + (non-terminatingp nil) + (readtable *readtable*)) #!+sb-doc - "Causes char to be a macro character which invokes function when - seen by the reader. The non-terminatingp flag can be used to - make the macro character non-terminating. The optional readtable - argument defaults to the current readtable. Set-macro-character - returns T." - (if non-terminatingp - (set-cat-entry char (get-secondary-attribute char) rt) - (set-cat-entry char #.terminating-macro rt)) - (set-cmt-entry char function rt) - T) - -(defun get-macro-character (char &optional rt) + "Causes CHAR to be a macro character which invokes FUNCTION when seen + by the reader. The NON-TERMINATINGP flag can be used to make the macro + character non-terminating, i.e. embeddable in a symbol name." + (let ((designated-readtable (or readtable *standard-readtable*))) + (set-cat-entry char + (if non-terminatingp + (get-secondary-attribute char) + +char-attr-terminating-macro+) + designated-readtable) + (set-cmt-entry char function designated-readtable) + t)) ; (ANSI-specified return value) + +(defun get-macro-character (char &optional (readtable *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*))) - ;; Check macro syntax, return associated function if it's there. - ;; Returns a value for all constituents. - (cond ((constituentp char) - (values (get-cmt-entry char rt) t)) - ((terminating-macrop char) - (values (get-cmt-entry char rt) nil)) - (t nil)))) + "Return the function associated with the specified CHAR which is a macro + character, or NIL if there is no such function. As a second value, return + T if CHAR is a macro character which is non-terminating, i.e. which can + be embedded in a symbol name." + (let* ((designated-readtable (or readtable *standard-readtable*)) + ;; the first return value: a FUNCTION if CHAR is a macro + ;; character, or NIL otherwise + (fun-value (get-raw-cmt-entry char designated-readtable))) + (values fun-value + ;; NON-TERMINATING-P return value: + (if fun-value + (or (constituentp char) + (not (terminating-macrop char))) + ;; ANSI's definition of GET-MACRO-CHARACTER says this + ;; value is NIL when CHAR is not a macro character. + ;; I.e. this value means not just "non-terminating + ;; character?" but "non-terminating macro character?". + nil)))) ;;;; definitions to support internal programming conventions -(defmacro eofp (char) `(eq ,char *eof-object*)) +(defmacro eofp (char) + `(eq ,char *eof-object*)) (defun flush-whitespace (stream) ;; This flushes whitespace chars, returning the last char it read (a ;; non-white one). It always gets an error on end-of-file. (let ((stream (in-synonym-of stream))) - (if (lisp-stream-p stream) + (if (ansi-stream-p stream) (prepare-for-fast-read-char stream (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) + +char-attr-whitespace+) (done-with-fast-read-char) char))) - ;; fundamental-stream + ;; CLOS stream (do ((attribute-table (character-attribute-table *readtable*)) - (char (stream-read-char stream) (stream-read-char stream))) + (char (read-char stream nil :eof) (read-char stream nil :eof))) ((or (eq char :eof) (/= (the fixnum (aref attribute-table (char-code char))) - #.whitespace)) + +char-attr-whitespace+)) (if (eq char :eof) (error 'end-of-file :stream stream) char)))))) @@ -260,27 +270,31 @@ (defun !cold-init-standard-readtable () (setq *standard-readtable* (make-readtable)) - ;; All characters default to "constituent" in MAKE-READTABLE. - ;; *** un-constituent-ize some of these *** + ;; All characters get boring defaults in MAKE-READTABLE. Now we + ;; override the boring defaults on characters which need more + ;; interesting behavior. (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) + + (flet ((whitespaceify (char) + (set-cat-entry char +char-attr-whitespace+))) + (whitespaceify (code-char tab-char-code)) + (whitespaceify #\linefeed) + (whitespaceify #\space) + (whitespaceify (code-char form-feed-char-code)) + (whitespaceify (code-char return-char-code))) + + (set-cat-entry #\\ +char-attr-escape+) (set-cmt-entry #\\ #'read-token) - (set-cat-entry (code-char rubout-char-code) #.whitespace) - (set-cmt-entry #\: #'read-token) - (set-cmt-entry #\| #'read-token) - ;; macro definitions + + ;; Easy macro-character definitions are in this source file. (set-macro-character #\" #'read-string) - ;; * # macro (set-macro-character #\' #'read-quote) (set-macro-character #\( #'read-list) (set-macro-character #\) #'read-right-paren) (set-macro-character #\; #'read-comment) - ;; * backquote + ;; (The hairier macro-character definitions, for #\# and #\`, are + ;; defined elsewhere, in their own source files.) + ;; all constituents (do ((ichar 0 (1+ ichar)) (char)) @@ -288,28 +302,29 @@ (setq char (code-char ichar)) (when (constituentp char *standard-readtable*) (set-cat-entry char (get-secondary-attribute char)) - (set-cmt-entry char #'read-token))))) + (set-cmt-entry char nil))))) ;;;; implementation of the read buffer (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*) (declaim (type index *read-buffer-length* *inch-ptr* *ouch-ptr*)) -(declaim (simple-string *read-buffer*)) +(declaim (type (simple-array character (*)) *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 +332,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 @@ -379,61 +395,69 @@ (declaim (special *standard-input*)) -;;; READ-PRESERVING-WHITESPACE behaves just like READ, only it makes sure -;;; to leave terminating whitespace in the stream. +;;; READ-PRESERVING-WHITESPACE behaves just like READ, only it makes +;;; sure to leave terminating whitespace in the stream. (This is a +;;; COMMON-LISP exported symbol.) (defun read-preserving-whitespace (&optional (stream *standard-input*) (eof-error-p t) (eof-value nil) (recursivep nil)) #!+sb-doc - "Reads from stream and returns the object read, preserving the whitespace + "Read from STREAM and return the value read, preserving any whitespace that followed the object." - (cond - (recursivep + (if recursivep ;; a loop for repeating when a macro returns nothing (loop (let ((char (read-char stream eof-error-p *eof-object*))) (cond ((eofp char) (return eof-value)) ((whitespacep char)) (t - (let* ((macrofun (get-cmt-entry char *readtable*)) + (let* ((macrofun (get-coerced-cmt-entry char *readtable*)) (result (multiple-value-list (funcall macrofun stream char)))) ;; Repeat if macro returned nothing. - (if result (return (car result))))))))) - (t + (if result (return (car result)))))))) (let ((*sharp-equal-alist* nil)) - (read-preserving-whitespace stream eof-error-p eof-value t))))) + (read-preserving-whitespace stream eof-error-p eof-value t)))) +;;; Return NIL or a list with one thing, depending. +;;; +;;; for functions that want comments to return so that they can look +;;; past them. We assume CHAR is not whitespace. (defun read-maybe-nothing (stream char) - ;;returns nil or a list with one thing, depending. - ;;for functions that want comments to return so they can look - ;;past them. Assumes char is not whitespace. (let ((retval (multiple-value-list - (funcall (get-cmt-entry char *readtable*) stream char)))) + (funcall (get-coerced-cmt-entry char *readtable*) + stream + char)))) (if retval (rplacd retval nil)))) -(defun read (&optional (stream *standard-input*) (eof-error-p t) - (eof-value ()) (recursivep ())) +(defun read (&optional (stream *standard-input*) + (eof-error-p t) + (eof-value ()) + (recursivep ())) #!+sb-doc - "Reads in the next object in the stream, which defaults to - *standard-input*. For details see the I/O chapter of - the manual." - (prog1 - (read-preserving-whitespace stream eof-error-p eof-value recursivep) - (let ((whitechar (read-char stream nil *eof-object*))) - (if (and (not (eofp whitechar)) - (or (not (whitespacep whitechar)) - recursivep)) - (unread-char whitechar stream))))) - + "Read the next Lisp value from STREAM, and return it." + (let ((result (read-preserving-whitespace stream + eof-error-p + eof-value + recursivep))) + ;; (This function generally discards trailing whitespace. If you + ;; don't want to discard trailing whitespace, call + ;; CL:READ-PRESERVING-WHITESPACE instead.) + (unless (or (eql result eof-value) recursivep) + (let ((next-char (read-char stream nil nil))) + (unless (or (null next-char) + (whitespacep next-char)) + (unread-char next-char stream)))) + result)) + +;;; (This is a COMMON-LISP exported symbol.) (defun read-delimited-list (endchar &optional (input-stream *standard-input*) recursive-p) #!+sb-doc - "Reads objects from input-stream until the next character after an - object's representation is endchar. A list of those objects read - is returned." + "Read Lisp values from INPUT-STREAM until the next character after a + value's representation is ENDCHAR, and return the objects as a list." (declare (ignore recursive-p)) (do ((char (flush-whitespace input-stream) (flush-whitespace input-stream)) @@ -443,8 +467,8 @@ ;;;; basic readmacro definitions ;;;; -;;;; Large, hairy subsets of readmacro definitions (backquotes and sharp -;;;; macros) are not here, but in their own source files. +;;;; Some large, hairy subsets of readmacro definitions (backquotes +;;;; and sharp macros) are not here, but in their own source files. (defun read-quote (stream ignore) (declare (ignore ignore)) @@ -453,14 +477,14 @@ (defun read-comment (stream ignore) (declare (ignore ignore)) (let ((stream (in-synonym-of stream))) - (if (lisp-stream-p stream) + (if (ansi-stream-p stream) (prepare-for-fast-read-char stream (do ((char (fast-read-char nil nil) (fast-read-char nil nil))) ((or (not char) (char= char #\newline)) (done-with-fast-read-char)))) - ;; FUNDAMENTAL-STREAM - (do ((char (stream-read-char stream) (stream-read-char stream))) + ;; CLOS stream + (do ((char (read-char stream nil :eof) (read-char stream nil :eof))) ((or (eq char :eof) (char= char #\newline)))))) ;; Don't return anything. (values)) @@ -516,20 +540,20 @@ ;; For a very long string, this could end up bloating the read buffer. (reset-read-buffer) (let ((stream (in-synonym-of stream))) - (if (lisp-stream-p stream) + (if (ansi-stream-p stream) (prepare-for-fast-read-char stream (do ((char (fast-read-char t) (fast-read-char t))) ((char= char closech) (done-with-fast-read-char)) (if (escapep char) (setq char (fast-read-char t))) (ouch-read-buffer char))) - ;; FUNDAMENTAL-STREAM - (do ((char (stream-read-char stream) (stream-read-char stream))) + ;; CLOS stream + (do ((char (read-char stream nil :eof) (read-char stream nil :eof))) ((or (eq char :eof) (char= char closech)) (if (eq char :eof) (error 'end-of-file :stream stream))) (when (escapep char) - (setq char (stream-read-char stream)) + (setq char (read-char stream nil :eof)) (if (eq char :eof) (error 'end-of-file :stream stream))) (ouch-read-buffer char)))) @@ -539,14 +563,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 +591,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 +601,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) + +char-attr-package-delimiter+) (not colon)) (setq colon *ouch-ptr*)) - (ouch-read-buffer char))))) + (ouch-read-buffer char)))))) ;;;; character classes @@ -592,57 +623,61 @@ (defmacro char-class (char attable) `(let ((att (aref ,attable (char-code ,char)))) (declare (fixnum att)) - (if (<= att #.terminating-macro) - #.delimiter + (if (<= att +char-attr-terminating-macro+) + +char-attr-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 +char-attr-terminating-macro+) + +char-attr-delimiter+ (if (digit-char-p ,char *read-base*) - constituent-digit - (if (= att constituent-digit) - constituent + +char-attr-constituent-digit+ + (if (= att +char-attr-constituent-digit+) + +char-attr-constituent+ att))))) -;;; Return the character class for a char which might be part of a rational or -;;; floating number. (Assume that it is a digit if it could be.) +;;; Return the character class for a char which might be part of a +;;; rational or floating number. (Assume that it is a digit if it +;;; could be.) (defmacro char-class3 (char attable) `(let ((att (aref ,attable (char-code ,char)))) (declare (fixnum att)) (if possibly-rational (setq possibly-rational (or (digit-char-p ,char *read-base*) - (= att constituent-slash)))) + (= att +char-attr-constituent-slash+)))) (if possibly-float (setq possibly-float (or (digit-char-p ,char 10) - (= att constituent-dot)))) - (if (<= att #.terminating-macro) - #.delimiter + (= att +char-attr-constituent-dot+)))) + (if (<= att +char-attr-terminating-macro+) + +char-attr-delimiter+ (if (digit-char-p ,char (max *read-base* 10)) (if (digit-char-p ,char *read-base*) - constituent-digit - constituent) + (if (= att +char-attr-constituent-expt+) + +char-attr-constituent-digit-or-expt+ + +char-attr-constituent-digit+) + +char-attr-constituent-decimal-digit+) att)))) ;;;; token fetching (defvar *read-suppress* nil #!+sb-doc - "Suppresses most interpreting of the reader when T") + "Suppress most interpreting in the reader when T.") (defvar *read-base* 10 #!+sb-doc - "The radix that Lisp reads numbers in.") + "the radix that Lisp reads numbers in") (declaim (type (integer 2 36) *read-base*)) -;;; Modify the read buffer according to READTABLE-CASE, ignoring escapes. -;;; ESCAPES is a list of the escaped indices, in reverse order. +;;; Modify the read buffer according to READTABLE-CASE, ignoring +;;; ESCAPES. ESCAPES is a list of the escaped indices, in reverse +;;; order. (defun casify-read-buffer (escapes) (let ((case (readtable-case *readtable*))) (cond @@ -662,7 +697,7 @@ (declare (fixnum esc)) (cond ((< esc i) t) (t - (assert (= esc i)) + (aver (= esc i)) (pop escapes) nil)))) (let ((ch (schar *read-buffer* i))) @@ -688,199 +723,254 @@ (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) (colons 0) (possibly-rational t) + (seen-digit-or-expt nil) (possibly-float t) - (escapes ())) + (was-possibly-float nil) + (escapes ()) + (seen-multiple-escapes nil)) (reset-read-buffer) (prog ((char firstchar)) (case (char-class3 char attribute-table) - (#.constituent-sign (go SIGN)) - (#.constituent-digit (go LEFTDIGIT)) - (#.constituent-dot (go FRONTDOT)) - (#.escape (go ESCAPE)) - (#.package-delimiter (go COLON)) - (#.multiple-escape (go MULT-ESCAPE)) - ;;can't have eof, whitespace, or terminating macro as first char! + (#.+char-attr-constituent-sign+ (go SIGN)) + (#.+char-attr-constituent-digit+ (go LEFTDIGIT)) + (#.+char-attr-constituent-digit-or-expt+ + (setq seen-digit-or-expt t) + (go LEFTDIGIT)) + (#.+char-attr-constituent-decimal-digit+ (go LEFTDECIMALDIGIT)) + (#.+char-attr-constituent-dot+ (go FRONTDOT)) + (#.+char-attr-escape+ (go ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + ;; 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)) (setq possibly-rational t possibly-float t) (case (char-class3 char attribute-table) - (#.constituent-digit (go LEFTDIGIT)) - (#.constituent-dot (go SIGNDOT)) - (#.escape (go ESCAPE)) - (#.package-delimiter (go COLON)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) + (#.+char-attr-constituent-digit+ (go LEFTDIGIT)) + (#.+char-attr-constituent-digit-or-expt+ + (setq seen-digit-or-expt t) + (go LEFTDIGIT)) + (#.+char-attr-constituent-decimal-digit+ (go LEFTDECIMALDIGIT)) + (#.+char-attr-constituent-dot+ (go SIGNDOT)) + (#.+char-attr-escape+ (go ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-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))) + (setq was-possibly-float possibly-float) (case (char-class3 char attribute-table) - (#.constituent-digit (go LEFTDIGIT)) - (#.constituent-dot (if possibly-float - (go MIDDLEDOT) - (go SYMBOL))) - (#.constituent-expt (go EXPONENT)) - (#.constituent-slash (if possibly-rational - (go RATIO) - (go SYMBOL))) - (#.delimiter (unread-char char stream) (return (make-integer))) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+char-attr-constituent-digit+ (go LEFTDIGIT)) + (#.+char-attr-constituent-decimal-digit+ (if possibly-float + (go LEFTDECIMALDIGIT) + (go SYMBOL))) + (#.+char-attr-constituent-dot+ (if possibly-float + (go MIDDLEDOT) + (go SYMBOL))) + (#.+char-attr-constituent-digit-or-expt+ + (if (or seen-digit-or-expt (not was-possibly-float)) + (progn (setq seen-digit-or-expt t) (go LEFTDIGIT)) + (progn (setq seen-digit-or-expt t) (go LEFTDIGIT-OR-EXPT)))) + (#.+char-attr-constituent-expt+ + (if was-possibly-float + (go EXPONENT) + (go SYMBOL))) + (#.+char-attr-constituent-slash+ (if possibly-rational + (go RATIO) + (go SYMBOL))) + (#.+char-attr-delimiter+ (unread-char char stream) + (return (make-integer))) + (#.+char-attr-escape+ (go ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) + LEFTDIGIT-OR-EXPT + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (return (make-integer))) + (case (char-class3 char attribute-table) + (#.+char-attr-constituent-digit+ (go LEFTDIGIT)) + (#.+char-attr-constituent-decimal-digit+ (bug "impossible!")) + (#.+char-attr-constituent-dot+ (go SYMBOL)) + (#.+char-attr-constituent-digit-or-expt+ (go LEFTDIGIT)) + (#.+char-attr-constituent-expt+ (go SYMBOL)) + (#.+char-attr-constituent-sign+ (go EXPTSIGN)) + (#.+char-attr-constituent-slash+ (if possibly-rational + (go RATIO) + (go SYMBOL))) + (#.+char-attr-delimiter+ (unread-char char stream) + (return (make-integer))) + (#.+char-attr-escape+ (go ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) + LEFTDECIMALDIGIT ; saw "[sign] {decimal-digit}+" + (aver possibly-float) + (ouch-read-buffer char) + (setq char (read-char stream nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class char attribute-table) + (#.+char-attr-constituent-digit+ (go LEFTDECIMALDIGIT)) + (#.+char-attr-constituent-dot+ (go MIDDLEDOT)) + (#.+char-attr-constituent-expt+ (go EXPONENT)) + (#.+char-attr-constituent-slash+ (aver (not possibly-rational)) + (go SYMBOL)) + (#.+char-attr-delimiter+ (unread-char char stream) + (go RETURN-SYMBOL)) + (#.+char-attr-escape+ (go ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-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)) (make-integer)))) (case (char-class char attribute-table) - (#.constituent-digit (go RIGHTDIGIT)) - (#.constituent-expt (go EXPONENT)) - (#.delimiter + (#.+char-attr-constituent-digit+ (go RIGHTDIGIT)) + (#.+char-attr-constituent-expt+ (go EXPONENT)) + (#.+char-attr-delimiter+ (unread-char char stream) (return (let ((*read-base* 10)) (make-integer)))) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+char-attr-escape+ (go ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) (t (go SYMBOL))) - RIGHTDIGIT - ;;saw "[sign] {digit}* dot {digit}+" + RIGHTDIGIT ; saw "[sign] {decimal-digit}* dot {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) - (unless char (return (make-float))) + (unless char (return (make-float stream))) (case (char-class char attribute-table) - (#.constituent-digit (go RIGHTDIGIT)) - (#.constituent-expt (go EXPONENT)) - (#.delimiter (unread-char char stream) (return (make-float))) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+char-attr-constituent-digit+ (go RIGHTDIGIT)) + (#.+char-attr-constituent-expt+ (go EXPONENT)) + (#.+char-attr-delimiter+ + (unread-char char stream) + (return (make-float stream))) + (#.+char-attr-escape+ (go ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-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)) (case (char-class char attribute-table) - (#.constituent-digit (go RIGHTDIGIT)) - (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) + (#.+char-attr-constituent-digit+ (go RIGHTDIGIT)) + (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) + (#.+char-attr-escape+ (go ESCAPE)) + (#.+char-attr-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")) (case (char-class char attribute-table) - (#.constituent-digit (go RIGHTDIGIT)) - (#.constituent-dot (go DOTS)) - (#.delimiter (%reader-error stream "dot context error")) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+char-attr-constituent-digit+ (go RIGHTDIGIT)) + (#.+char-attr-constituent-dot+ (go DOTS)) + (#.+char-attr-delimiter+ (%reader-error stream "dot context error")) + (#.+char-attr-escape+ (go ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) (t (go SYMBOL))) EXPONENT (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) + (setq possibly-float t) (case (char-class char attribute-table) - (#.constituent-sign (go EXPTSIGN)) - (#.constituent-digit (go EXPTDIGIT)) - (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+char-attr-constituent-sign+ (go EXPTSIGN)) + (#.+char-attr-constituent-digit+ (go EXPTDIGIT)) + (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) + (#.+char-attr-escape+ (go ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-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)) (case (char-class char attribute-table) - (#.constituent-digit (go EXPTDIGIT)) - (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+char-attr-constituent-digit+ (go EXPTDIGIT)) + (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) + (#.+char-attr-escape+ (go ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-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))) + (unless char (return (make-float stream))) (case (char-class char attribute-table) - (#.constituent-digit (go EXPTDIGIT)) - (#.delimiter (unread-char char stream) (return (make-float))) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+char-attr-constituent-digit+ (go EXPTDIGIT)) + (#.+char-attr-delimiter+ + (unread-char char stream) + (return (make-float stream))) + (#.+char-attr-escape+ (go ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-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)) (case (char-class2 char attribute-table) - (#.constituent-digit (go RATIODIGIT)) - (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+char-attr-constituent-digit+ (go RATIODIGIT)) + (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) + (#.+char-attr-escape+ (go ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-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))) + (unless char (return (make-ratio stream))) (case (char-class2 char attribute-table) - (#.constituent-digit (go RATIODIGIT)) - (#.delimiter (unread-char char stream) (return (make-ratio))) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+char-attr-constituent-digit+ (go RATIODIGIT)) + (#.+char-attr-delimiter+ + (unread-char char stream) + (return (make-ratio stream))) + (#.+char-attr-escape+ (go ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-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")) (case (char-class char attribute-table) - (#.constituent-dot (go DOTS)) - (#.delimiter + (#.+char-attr-constituent-dot+ (go DOTS)) + (#.+char-attr-delimiter+ (unread-char char stream) (%reader-error stream "too many dots")) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+char-attr-escape+ (go ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-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) + (if (ansi-stream-p stream) (prepare-for-fast-read-char stream (prog () SYMBOL-LOOP @@ -888,33 +978,32 @@ (setq char (fast-read-char nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table) - (#.escape (done-with-fast-read-char) - (go ESCAPE)) - (#.delimiter (done-with-fast-read-char) - (unread-char char stream) - (go RETURN-SYMBOL)) - (#.multiple-escape (done-with-fast-read-char) - (go MULT-ESCAPE)) - (#.package-delimiter (done-with-fast-read-char) - (go COLON)) + (#.+char-attr-escape+ (done-with-fast-read-char) + (go ESCAPE)) + (#.+char-attr-delimiter+ (done-with-fast-read-char) + (unread-char char stream) + (go RETURN-SYMBOL)) + (#.+char-attr-multiple-escape+ (done-with-fast-read-char) + (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (done-with-fast-read-char) + (go COLON)) (t (go SYMBOL-LOOP))))) - ;; fundamental-stream + ;; CLOS stream (prog () SYMBOL-LOOP (ouch-read-buffer char) - (setq char (stream-read-char stream)) + (setq char (read-char stream nil :eof)) (when (eq char :eof) (go RETURN-SYMBOL)) (case (char-class char attribute-table) - (#.escape (go ESCAPE)) - (#.delimiter (stream-unread-char stream char) + (#.+char-attr-escape+ (go ESCAPE)) + (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-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")) @@ -923,12 +1012,13 @@ (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table) - (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) + (#.+char-attr-escape+ (go ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) (t (go SYMBOL))) MULT-ESCAPE + (setq seen-multiple-escapes t) (do ((char (read-char stream t) (read-char stream t))) ((multiple-escape-p char)) (if (escapep char) (setq char (read-char stream t))) @@ -937,10 +1027,10 @@ (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table) - (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) + (#.+char-attr-escape+ (go ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) (t (go SYMBOL))) COLON (casify-read-buffer escapes) @@ -956,20 +1046,22 @@ ;; a FIND-PACKAGE* function analogous to INTERN* ;; and friends? (read-buffer-to-string) - *keyword-package*)) + (if seen-multiple-escapes + (read-buffer-to-string) + *keyword-package*))) (reset-read-buffer) (setq escapes ()) (setq char (read-char stream nil nil)) (unless char (reader-eof-error stream "after reading a colon")) (case (char-class char attribute-table) - (#.delimiter + (#.+char-attr-delimiter+ (unread-char char stream) (%reader-error stream "illegal terminating character after a colon: ~S" char)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go INTERN)) + (#.+char-attr-escape+ (go ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go INTERN)) (t (go SYMBOL))) INTERN (setq colons 2) @@ -977,14 +1069,14 @@ (unless char (reader-eof-error stream "after reading a colon")) (case (char-class char attribute-table) - (#.delimiter + (#.+char-attr-delimiter+ (unread-char char stream) (%reader-error stream "illegal terminating character after a colon: ~S" char)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter + (#.+char-attr-escape+ (go ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (%reader-error stream "too many colons after ~S name" package-designator)) @@ -1014,26 +1106,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) @@ -1106,7 +1212,7 @@ (the index (* num base)))))))) (setq number (+ num (* number base-power))))))) -(defun make-float () +(defun make-float (stream) ;; Assume that the contents of *read-buffer* are a legal float, with nothing ;; else after it. (read-unwind-read-buffer) @@ -1140,7 +1246,8 @@ (cond ((eofp char) ;; If not, we've read the whole number. (let ((num (make-float-aux number divisor - *read-default-float-format*))) + *read-default-float-format* + stream))) (return-from make-float (if negative-fraction (- num) num)))) ((exponent-letterp char) (setq float-char char) @@ -1158,7 +1265,7 @@ ((not dig) (setq exponent (if negative-exponent (- exponent) exponent))) (setq exponent (+ (* exponent 10) dig))) - ;; Generate and return the float, depending on float-char: + ;; Generate and return the float, depending on FLOAT-CHAR: (let* ((float-format (case (char-upcase float-char) (#\E *read-default-float-format*) (#\S 'short-float) @@ -1166,29 +1273,31 @@ (#\D 'double-float) (#\L 'long-float))) num) - ;; toy@rtp.ericsson.se: We need to watch out if the + ;; Raymond Toy writes: We need to watch out if the ;; exponent is too small or too large. We add enough to ;; EXPONENT to make it within range and scale NUMBER ;; 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, as the + ;; cross-compiler will call the host's LOG function + ;; while attempting to constant-fold. Maybe some sort + ;; of load-time-form magic could be used instead? (case float-format - (short-float - (values - #.(log least-positive-normalized-short-float 10s0) - #.(log most-positive-short-float 10s0))) - (single-float + ((short-float single-float) (values - #.(log least-positive-normalized-single-float 10f0) - #.(log most-positive-single-float 10f0))) - (double-float + (log sb!xc:least-positive-normalized-single-float 10f0) + (log sb!xc:most-positive-single-float 10f0))) + ((double-float #!-long-float long-float) (values - #.(log least-positive-normalized-double-float 10d0) - #.(log most-positive-double-float 10d0))) + (log sb!xc:least-positive-normalized-double-float 10d0) + (log sb!xc:most-positive-double-float 10d0))) + #!+long-float (long-float (values - #.(log least-positive-normalized-long-float 10L0) - #.(log most-positive-long-float 10L0)))) + (log sb!xc:least-positive-normalized-long-float 10l0) + (log sb!xc:most-positive-long-float 10l0)))) (let ((correction (cond ((<= exponent min-expo) (ceiling (- min-expo exponent))) ((>= exponent max-expo) @@ -1197,17 +1306,24 @@ 0)))) (incf exponent correction) (setf number (/ number (expt 10 correction))) - (setq num (make-float-aux number divisor float-format)) + (setq num (make-float-aux number divisor float-format stream)) (setq num (* num (expt 10 exponent))) - (return-from make-float (if negative-fraction (- num) num)))))) - ;; should never happen: - (t (error "internal error in floating point reader"))))) - -(defun make-float-aux (number divisor float-format) - (coerce (/ number divisor) float-format)) - -(defun make-ratio () - ;; Assume *read-buffer* contains a legal ratio. Build the number from + (return-from make-float (if negative-fraction + (- num) + num)))))) + ;; should never happen + (t (bug "bad fallthrough in floating point reader"))))) + +(defun make-float-aux (number divisor float-format stream) + (handler-case + (coerce (/ number divisor) float-format) + (type-error (c) + (error 'reader-impossible-number-error + :error c :stream stream + :format-control "failed to build float")))) + +(defun make-ratio (stream) + ;; Assume *READ-BUFFER* contains a legal ratio. Build the number from ;; the string. ;; ;; Look for optional "+" or "-". @@ -1230,7 +1346,12 @@ (dig ())) ((or (eofp ch) (not (setq dig (digit-char-p ch *read-base*))))) (setq denominator (+ (* denominator *read-base*) dig))) - (let ((num (/ numerator denominator))) + (let ((num (handler-case + (/ numerator denominator) + (arithmetic-error (c) + (error 'reader-impossible-number-error + :error c :stream stream + :format-control "failed to build ratio"))))) (if negative-number (- num) num)))) ;;;; cruft for dispatch macros @@ -1248,30 +1369,30 @@ (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)))))) + (push (cons char (make-char-dispatch-table)) dalist))))) + t) -(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) (error "SUB-CHAR must not be a decimal digit: ~S" sub-char)) (let* ((sub-char (char-upcase sub-char)) + (rt (or rt *standard-readtable*)) (dpair (find disp-char (dispatch-tables rt) :test #'char= :key #'car))) (if dpair @@ -1280,19 +1401,25 @@ (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*)) - (dpair (find disp-char (dispatch-tables rt) - :test #'char= :key #'car))) - (if dpair - (elt (the simple-vector (cdr dpair)) - (char-code sub-char)) - (error "~S is not a dispatch char." disp-char))))) + "Return the macro character function for SUB-CHAR under DISP-CHAR + or NIL if there is no associated function." + (let* ((sub-char (char-upcase sub-char)) + (rt (or rt *standard-readtable*)) + (dpair (find disp-char (dispatch-tables rt) + :test #'char= :key #'car))) + (if dpair + (let ((dispatch-fun (elt (the simple-vector (cdr dpair)) + (char-code sub-char)))) + ;; Digits are also initialized in a dispatch table to + ;; #'dispatch-char-error; READ-DISPATCH-CHAR handles them + ;; separately. - CSR, 2002-04-12 + (if (eq dispatch-fun #'dispatch-char-error) + nil + dispatch-fun)) + (error "~S is not a dispatch char." disp-char)))) (defun read-dispatch-char (stream char) ;; Read some digits. @@ -1335,9 +1462,10 @@ and the lisp object built by the reader is returned. Macro chars will take effect." (declare (string string)) + (with-array-data ((string string) (start start) - (end (or end (length string)))) + (end (%check-vector-sequence-bounds string start end))) (unless *read-from-string-spares* (push (internal-make-string-input-stream "" 0 0) *read-from-string-spares*)) @@ -1360,51 +1488,55 @@ (default to the beginning and end of the string) It skips over whitespace characters and then tries to parse an integer. The radix parameter must be between 2 and 36." - (with-array-data ((string string) - (start start) - (end (or end (length string)))) - (let ((index (do ((i start (1+ i))) - ((= i end) - (if junk-allowed - (return-from parse-integer (values nil end)) - (error "no non-whitespace characters in number"))) - (declare (fixnum i)) - (unless (whitespacep (char string i)) (return i)))) - (minusp nil) - (found-digit nil) - (result 0)) - (declare (fixnum index)) - (let ((char (char string index))) - (cond ((char= char #\-) - (setq minusp t) - (incf index)) - ((char= char #\+) - (incf index)))) - (loop - (when (= index end) (return nil)) - (let* ((char (char string index)) - (weight (digit-char-p char radix))) - (cond (weight - (setq result (+ weight (* result radix)) - found-digit t)) - (junk-allowed (return nil)) - ((whitespacep char) - (do ((jndex (1+ index) (1+ jndex))) - ((= jndex end)) - (declare (fixnum jndex)) - (unless (whitespacep (char string jndex)) - (error "junk in string ~S" string))) - (return nil)) - (t - (error "junk in string ~S" string)))) - (incf index)) - (values - (if found-digit - (if minusp (- result) result) - (if junk-allowed - nil - (error "no digits in string ~S" string))) - index)))) + (macrolet ((parse-error (format-control) + `(error 'simple-parse-error + :format-control ,format-control + :format-arguments (list string)))) + (with-array-data ((string string :offset-var offset) + (start start) + (end (%check-vector-sequence-bounds string start end))) + (let ((index (do ((i start (1+ i))) + ((= i end) + (if junk-allowed + (return-from parse-integer (values nil end)) + (parse-error "no non-whitespace characters in string ~S."))) + (declare (fixnum i)) + (unless (whitespacep (char string i)) (return i)))) + (minusp nil) + (found-digit nil) + (result 0)) + (declare (fixnum index)) + (let ((char (char string index))) + (cond ((char= char #\-) + (setq minusp t) + (incf index)) + ((char= char #\+) + (incf index)))) + (loop + (when (= index end) (return nil)) + (let* ((char (char string index)) + (weight (digit-char-p char radix))) + (cond (weight + (setq result (+ weight (* result radix)) + found-digit t)) + (junk-allowed (return nil)) + ((whitespacep char) + (loop + (incf index) + (when (= index end) (return)) + (unless (whitespacep (char string index)) + (parse-error "junk in string ~S"))) + (return nil)) + (t + (parse-error "junk in string ~S")))) + (incf index)) + (values + (if found-digit + (if minusp (- result) result) + (if junk-allowed + nil + (parse-error "no digits in string ~S"))) + (- index offset)))))) ;;;; reader initialization code