X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Freader.lisp;h=8f885fa97279d74e279b25087a6cf9314b0b0ed9;hb=7f1e94ae961a198e00daf281eb1dc858e5b2dcc7;hp=2372ef8750fd2165af1f6dee3cd7f5fe36d6b739;hpb=93ba859423ec6e035a7b22a76a2ac70038691d65;p=sbcl.git diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 2372ef8..8f885fa 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -18,18 +18,18 @@ ;;; 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*)) + *read-default-float-format*)) (defvar *readtable*) (declaim (type readtable *readtable*)) #!+sb-doc (setf (fdocumentation '*readtable* 'variable) - "Variable bound to current readtable.") + "Variable bound to current readtable.") -;;; a standard Lisp readtable. This is for recovery from broken -;;; read-tables (and for WITH-STANDARD-IO-SYNTAX), and should not -;;; normally be user-visible. -(defvar *standard-readtable*) +;;; A standard Lisp readtable (once cold-init is through). This is for +;;; recovery from broken read-tables (and for +;;; WITH-STANDARD-IO-SYNTAX), and should not normally be user-visible. +(defvar *standard-readtable* nil) (defvar *old-package* nil #!+sb-doc @@ -46,55 +46,67 @@ (defun reader-eof-error (stream context) (error 'reader-eof-error - :stream stream - :context context)) - -(defun %reader-error (stream control &rest args) - (error 'reader-error - :stream stream - :format-control control - :format-arguments args)) + :stream stream + :context context)) + +;;; If The Gods didn't intend for us to use multiple namespaces, why +;;; did They specify them? +(defun simple-reader-error (stream control &rest args) + (error 'simple-reader-error + :stream stream + :format-control control + :format-arguments args)) ;;;; macros and functions for character tables -;;; FIXME: could be SB!XC:DEFMACRO inside EVAL-WHEN (COMPILE EVAL) -(defmacro get-cat-entry (char rt) - ;; KLUDGE: Only give this side-effect-free args. - ;; FIXME: should probably become inline function - `(elt (character-attribute-table ,rt) - (char-code ,char))) +(defun get-cat-entry (char rt) + (declare (readtable rt)) + (if (typep char 'base-char) + (elt (character-attribute-array rt) (char-code char)) + (values (gethash char (character-attribute-hash-table rt) + +char-attr-constituent+)))) (defun set-cat-entry (char newvalue &optional (rt *readtable*)) - (setf (elt (character-attribute-table rt) - (char-code char)) - newvalue)) + (declare (readtable rt)) + (if (typep char 'base-char) + (setf (elt (character-attribute-array rt) (char-code char)) newvalue) + (if (= newvalue +char-attr-constituent+) + ;; Default value for the C-A-HASH-TABLE is +CHAR-ATTR-CONSTITUENT+. + (%remhash char (character-attribute-hash-table rt)) + (setf (gethash char (character-attribute-hash-table rt)) newvalue))) + (values)) ;;; 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)))) +(defun get-raw-cmt-entry (char readtable) + (declare (readtable readtable)) + (if (typep char 'base-char) + (svref (character-macro-array readtable) (char-code char)) + ;; Note: DEFAULT here is NIL, not #'UNDEFINED-MACRO-CHAR, so + ;; that everything above the base-char range is a non-macro + ;; constituent by default. + (values (gethash char (character-macro-hash-table readtable) nil)))) ;;; 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 + (the function (or (get-raw-cmt-entry char readtable) - #'read-token))) + #'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)))) + (let ((new (when new-value-designator + (%coerce-callable-to-fun new-value-designator)))) + (if (typep char 'base-char) + (setf (svref (character-macro-array rt) (char-code char)) new) + (setf (gethash char (character-macro-hash-table rt)) new)))) (defun undefined-macro-char (stream char) (unless *read-suppress* - (%reader-error stream "undefined read-macro character ~S" char))) + (simple-reader-error stream "undefined read-macro character ~S" char))) ;;; The character attribute table is a CHAR-CODE-LIMIT vector of integers. @@ -103,283 +115,402 @@ ;;; predicates for testing character attributes -#!-sb-fluid (declaim (inline whitespacep)) -(defun whitespacep (char &optional (rt *readtable*)) +#!-sb-fluid +(progn + (declaim (inline whitespace[1]p whitespace[2]p)) + (declaim (inline constituentp terminating-macrop)) + (declaim (inline single-escape-p multiple-escape-p)) + (declaim (inline token-delimiterp))) + +;;; the [1] and [2] here refer to ANSI glossary entries for +;;; "whitespace". +(defun whitespace[1]p (char) + (test-attribute char +char-attr-whitespace+ *standard-readtable*)) +(defun whitespace[2]p (char &optional (rt *readtable*)) (test-attribute char +char-attr-whitespace+ rt)) -(defmacro constituentp (char &optional (rt '*readtable*)) - `(>= (get-cat-entry ,char ,rt) +char-attr-constituent+)) +(defun constituentp (char &optional (rt *readtable*)) + (test-attribute char +char-attr-constituent+ rt)) -(defmacro terminating-macrop (char &optional (rt '*readtable*)) - `(test-attribute ,char +char-attr-terminating-macro+ ,rt)) +(defun terminating-macrop (char &optional (rt *readtable*)) + (test-attribute char +char-attr-terminating-macro+ rt)) -(defmacro escapep (char &optional (rt '*readtable*)) - `(test-attribute ,char +char-attr-escape+ ,rt)) +(defun single-escape-p (char &optional (rt *readtable*)) + (test-attribute char +char-attr-single-escape+ rt)) -(defmacro multiple-escape-p (char &optional (rt '*readtable*)) - `(test-attribute ,char +char-attr-multiple-escape+ ,rt)) +(defun multiple-escape-p (char &optional (rt *readtable*)) + (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) +char-attr-terminating-macro+)) +(defun token-delimiterp (char &optional (rt *readtable*)) + ;; depends on actual attribute numbering in readtable.lisp. + (<= (get-cat-entry char rt) +char-attr-terminating-macro+)) -;;;; secondary attribute table +;;;; constituent traits (see ANSI 2.1.4.2) ;;; 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*)) - -(defun !set-secondary-attribute (char attribute) - (setf (elt *secondary-attribute-table* (char-code char)) - attribute)) - -(defun !cold-init-secondary-attribute-table () - (setq *secondary-attribute-table* - (make-array char-code-limit :element-type '(unsigned-byte 8) - :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+) +(defvar *constituent-trait-table*) +(declaim (type attribute-table *constituent-trait-table*)) + +(defun !set-constituent-trait (char trait) + (aver (typep char 'base-char)) + (setf (elt *constituent-trait-table* (char-code char)) + trait)) + +(defun !cold-init-constituent-trait-table () + (setq *constituent-trait-table* + (make-array base-char-code-limit :element-type '(unsigned-byte 8) + :initial-element +char-attr-constituent+)) + (!set-constituent-trait #\: +char-attr-package-delimiter+) + (!set-constituent-trait #\. +char-attr-constituent-dot+) + (!set-constituent-trait #\+ +char-attr-constituent-sign+) + (!set-constituent-trait #\- +char-attr-constituent-sign+) + (!set-constituent-trait #\/ +char-attr-constituent-slash+) (do ((i (char-code #\0) (1+ i))) ((> i (char-code #\9))) - (!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* - (char-code ,char))) + (!set-constituent-trait (code-char i) +char-attr-constituent-digit+)) + (!set-constituent-trait #\E +char-attr-constituent-expt+) + (!set-constituent-trait #\F +char-attr-constituent-expt+) + (!set-constituent-trait #\D +char-attr-constituent-expt+) + (!set-constituent-trait #\S +char-attr-constituent-expt+) + (!set-constituent-trait #\L +char-attr-constituent-expt+) + (!set-constituent-trait #\e +char-attr-constituent-expt+) + (!set-constituent-trait #\f +char-attr-constituent-expt+) + (!set-constituent-trait #\d +char-attr-constituent-expt+) + (!set-constituent-trait #\s +char-attr-constituent-expt+) + (!set-constituent-trait #\l +char-attr-constituent-expt+) + (!set-constituent-trait #\Space +char-attr-invalid+) + (!set-constituent-trait #\Newline +char-attr-invalid+) + (dolist (c (list backspace-char-code tab-char-code form-feed-char-code + return-char-code rubout-char-code)) + (!set-constituent-trait (code-char c) +char-attr-invalid+))) + +(declaim (inline get-constituent-trait)) +(defun get-constituent-trait (char) + (if (typep char 'base-char) + (elt *constituent-trait-table* (char-code char)) + +char-attr-constituent+)) -;;;; readtable operations +;;;; Readtable Operations + +(defun assert-not-standard-readtable (readtable operation) + (when (eq readtable *standard-readtable*) + (cerror "Frob it anyway!" 'standard-readtable-modified-error + :operation operation))) + +(defun readtable-case (readtable) + (%readtable-case readtable)) -(defun copy-readtable (&optional (from-readtable *readtable*) - to-readtable) +(defun (setf readtable-case) (case readtable) + (assert-not-standard-readtable readtable '(setf readtable-case)) + (setf (%readtable-case readtable) case)) + +(defun shallow-replace/eql-hash-table (to from) + (maphash (lambda (k v) (setf (gethash k to) v)) from)) + +(defun copy-readtable (&optional (from-readtable *readtable*) to-readtable) + (assert-not-standard-readtable to-readtable 'copy-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 really-to-readtable) - (character-macro-table really-from-readtable)) + (replace (character-attribute-array really-to-readtable) + (character-attribute-array really-from-readtable)) + (shallow-replace/eql-hash-table + (character-attribute-hash-table really-to-readtable) + (character-attribute-hash-table really-from-readtable)) + (replace (character-macro-array really-to-readtable) + (character-macro-array really-from-readtable)) + (shallow-replace/eql-hash-table + (character-macro-hash-table really-to-readtable) + (character-macro-hash-table really-from-readtable)) (setf (dispatch-tables really-to-readtable) - (mapcar (lambda (pair) (cons (car pair) - (copy-seq (cdr pair)))) - (dispatch-tables really-from-readtable))) + (mapcar (lambda (pair) + (cons (car pair) + (let ((table (make-hash-table))) + (shallow-replace/eql-hash-table table (cdr pair)) + table))) + (dispatch-tables really-from-readtable))) (setf (readtable-case really-to-readtable) - (readtable-case really-from-readtable)) + (readtable-case really-from-readtable)) really-to-readtable)) (defun set-syntax-from-char (to-char from-char &optional - (to-readtable *readtable*) - (from-readtable ())) + (to-readtable *readtable*) (from-readtable nil)) #!+sb-doc - "Causes the syntax of TO-CHAR to be the same as FROM-CHAR in the - optional readtable (defaults to the current readtable). The - FROM-TABLE defaults to the standard Lisp readtable when NIL." + "Causes the syntax of TO-CHAR to be the same as FROM-CHAR in the optional +readtable (defaults to the current readtable). The FROM-TABLE defaults to the +standard Lisp readtable when NIL." + (assert-not-standard-readtable to-readtable 'set-syntax-from-char) (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 - ;; 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))) - (if (constituentp from-char really-from-readtable) - (setq att (get-secondary-attribute to-char))) + (let ((att (get-cat-entry from-char really-from-readtable)) + (mac (get-raw-cmt-entry from-char really-from-readtable)) + (from-dpair (find from-char (dispatch-tables really-from-readtable) + :test #'char= :key #'car)) + (to-dpair (find to-char (dispatch-tables to-readtable) + :test #'char= :key #'car))) (set-cat-entry to-char att to-readtable) - (set-cmt-entry to-char - (get-raw-cmt-entry from-char really-from-readtable) - to-readtable))) + (set-cmt-entry to-char mac to-readtable) + (cond ((and (not from-dpair) (not to-dpair))) + ((and (not from-dpair) to-dpair) + (setf (dispatch-tables to-readtable) + (remove to-dpair (dispatch-tables to-readtable)))) + (to-dpair + (let ((table (cdr to-dpair))) + (clrhash table) + (shallow-replace/eql-hash-table table (cdr from-dpair)))) + (t + (let ((pair (cons to-char (make-hash-table)))) + (shallow-replace/eql-hash-table (cdr pair) (cdr from-dpair)) + (setf (dispatch-tables to-readtable) + (push pair (dispatch-tables to-readtable)))))))) t) (defun set-macro-character (char function &optional - (non-terminatingp nil) - (readtable *readtable*)) + (non-terminatingp nil) + (rt-designator *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, 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) + (let ((designated-readtable (or rt-designator *standard-readtable*)) + (function (%coerce-callable-to-fun function))) + (assert-not-standard-readtable designated-readtable 'set-macro-character) + (set-cat-entry char (if non-terminatingp + +char-attr-constituent+ + +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*)) +(defun get-macro-character (char &optional (rt-designator *readtable*)) #!+sb-doc "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))) + (let* ((designated-readtable (or rt-designator *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)))) + ;; NON-TERMINATING-P return value: + (if fun-value + (or (constituentp char designated-readtable) + (not (terminating-macrop char designated-readtable))) + ;; 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)))) + + +(defun make-char-dispatch-table () + (make-hash-table)) + +(defun make-dispatch-macro-character (char &optional + (non-terminating-p nil) + (rt *readtable*)) + #!+sb-doc + "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." + ;; Checks already for standard readtable modification. + (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 "The dispatch character ~S already exists." char)) + (t + (setf (dispatch-tables rt) + (push (cons char (make-char-dispatch-table)) dalist))))) + t) + +(defun set-dispatch-macro-character (disp-char sub-char function + &optional (rt-designator *readtable*)) + #!+sb-doc + "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. + (let* ((sub-char (char-upcase sub-char)) + (readtable (or rt-designator *standard-readtable*))) + (assert-not-standard-readtable readtable 'set-dispatch-macro-character) + (when (digit-char-p sub-char) + (error "SUB-CHAR must not be a decimal digit: ~S" sub-char)) + (let ((dpair (find disp-char (dispatch-tables readtable) + :test #'char= :key #'car))) + (if dpair + (setf (gethash sub-char (cdr dpair)) (coerce function 'function)) + (error "~S is not a dispatch char." disp-char)))) + t) + +(defun get-dispatch-macro-character (disp-char sub-char + &optional (rt-designator *readtable*)) + #!+sb-doc + "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)) + (readtable (or rt-designator *standard-readtable*)) + (dpair (find disp-char (dispatch-tables readtable) + :test #'char= :key #'car))) + (if dpair + (values (gethash sub-char (cdr dpair))) + (error "~S is not a dispatch char." disp-char)))) + ;;;; definitions to support internal programming conventions -(defmacro eofp (char) - `(eq ,char *eof-object*)) +(declaim (inline eofp)) +(defun 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 (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))) - +char-attr-whitespace+) - (done-with-fast-read-char) - char))) - ;; fundamental-stream - (do ((attribute-table (character-attribute-table *readtable*)) - (char (stream-read-char stream) (stream-read-char stream))) - ((or (eq char :eof) - (/= (the fixnum (aref attribute-table (char-code char))) - +char-attr-whitespace+)) - (if (eq char :eof) - (error 'end-of-file :stream stream) - char)))))) + (prepare-for-fast-read-char stream + (do ((attribute-array (character-attribute-array *readtable*)) + (attribute-hash-table + (character-attribute-hash-table *readtable*)) + (char (fast-read-char t) (fast-read-char t))) + ((/= (the fixnum + (if (typep char 'base-char) + (aref attribute-array (char-code char)) + (gethash char attribute-hash-table + +char-attr-constituent+))) + +char-attr-whitespace+) + (done-with-fast-read-char) + char))) + ;; CLOS stream + (do ((attribute-array (character-attribute-array *readtable*)) + (attribute-hash-table + (character-attribute-hash-table *readtable*)) + (char (read-char stream nil :eof) (read-char stream nil :eof))) + ((or (eq char :eof) + (/= (the fixnum + (if (typep char 'base-char) + (aref attribute-array (char-code char)) + (gethash char attribute-hash-table + +char-attr-constituent+))) + +char-attr-whitespace+)) + (if (eq char :eof) + (error 'end-of-file :stream stream) + char)))))) ;;;; temporary initialization hack +;; Install the (easy) standard macro-chars into *READTABLE*. (defun !cold-init-standard-readtable () - (setq *standard-readtable* (make-readtable)) + (/show0 "entering !cold-init-standard-readtable") ;; 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*)) - - (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) - - ;; Easy macro-character definitions are in this source file. - (set-macro-character #\" #'read-string) - (set-macro-character #\' #'read-quote) - (set-macro-character #\( #'read-list) - (set-macro-character #\) #'read-right-paren) - (set-macro-character #\; #'read-comment) - ;; (The hairier macro-character definitions, for #\# and #\`, are - ;; defined elsewhere, in their own source files.) - - ;; all constituents - (do ((ichar 0 (1+ ichar)) - (char)) - ((= ichar #O200)) - (setq char (code-char ichar)) - (when (constituentp char *standard-readtable*) - (set-cat-entry char (get-secondary-attribute char)) - (set-cmt-entry char nil))))) + (flet ((whitespaceify (char) + (set-cmt-entry char nil) + (set-cat-entry char +char-attr-whitespace+))) + (whitespaceify (code-char tab-char-code)) + (whitespaceify #\Newline) + (whitespaceify #\Space) + (whitespaceify (code-char form-feed-char-code)) + (whitespaceify (code-char return-char-code))) + + (set-cat-entry #\\ +char-attr-single-escape+) + (set-cmt-entry #\\ nil) + + (set-cat-entry #\| +char-attr-multiple-escape+) + (set-cmt-entry #\| nil) + + ;; Easy macro-character definitions are in this source file. + (set-macro-character #\" #'read-string) + (set-macro-character #\' #'read-quote) + (set-macro-character #\( #'read-list) + (set-macro-character #\) #'read-right-paren) + (set-macro-character #\; #'read-comment) + ;; (The hairier macro-character definitions, for #\# and #\`, are + ;; defined elsewhere, in their own source files.) + + ;; all constituents + (do ((ichar 0 (1+ ichar)) + (char)) + ((= ichar base-char-code-limit)) + (setq char (code-char ichar)) + (when (constituentp char) + (set-cmt-entry char nil))) + + (/show0 "leaving !cold-init-standard-readtable")) ;;;; 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*)? -(defvar *inch-ptr*) -(defvar *ouch-ptr*) +(defvar *inch-ptr*) ; *OUCH-PTR* always points to next char to write. +(defvar *ouch-ptr*) ; *INCH-PTR* always points to next char to read. -(declaim (type index *read-buffer-length* *inch-ptr* *ouch-ptr*)) -(declaim (simple-string *read-buffer*)) +(declaim (type index *inch-ptr* *ouch-ptr*)) +(declaim (type (simple-array character (*)) *read-buffer*)) -(defmacro reset-read-buffer () +(declaim (inline reset-read-buffer)) +(defun reset-read-buffer () ;; Turn *READ-BUFFER* into an empty read buffer. - `(progn - ;; *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 - (setq *read-buffer-length* 512) - (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. - -(defmacro ouch-read-buffer (char) - `(progn - ;; When buffer overflow - (when (>= *ouch-ptr* *read-buffer-length*) - ;; Size should be doubled. - (grow-read-buffer)) - (setf (elt (the simple-string *read-buffer*) *ouch-ptr*) ,char) - (setq *ouch-ptr* (1+ *ouch-ptr*)))) - -;;; macro to move *ouch-ptr* back one. -(defmacro ouch-unread-buffer () - '(when (> *ouch-ptr* *inch-ptr*) - (setq *ouch-ptr* (1- (the fixnum *ouch-ptr*))))) + (setq *ouch-ptr* 0) + (setq *inch-ptr* 0)) + +(declaim (inline ouch-read-buffer)) +(defun ouch-read-buffer (char) + ;; When buffer overflow + (let ((op *ouch-ptr*)) + (declare (optimize (sb!c::insert-array-bounds-checks 0))) + (when (>= op (length *read-buffer*)) + ;; Size should be doubled. + (grow-read-buffer)) + (setf (elt *read-buffer* op) char) + (setq *ouch-ptr* (1+ op)))) (defun grow-read-buffer () - (let ((rbl (length (the simple-string *read-buffer*)))) - (setq *read-buffer* - (concatenate 'simple-string - *read-buffer* - (make-string rbl))) - (setq *read-buffer-length* (* 2 rbl)))) - -(defun inchpeek-read-buffer () - (if (>= (the fixnum *inch-ptr*) (the fixnum *ouch-ptr*)) - *eof-object* - (elt *read-buffer* *inch-ptr*))) + (let* ((rbl (length *read-buffer*)) + (new-length (* 2 rbl)) + (new-buffer (make-string new-length))) + (setq *read-buffer* (replace new-buffer *read-buffer*)))) (defun inch-read-buffer () (if (>= *inch-ptr* *ouch-ptr*) *eof-object* (prog1 - (elt *read-buffer* *inch-ptr*) - (incf *inch-ptr*)))) + (elt *read-buffer* *inch-ptr*) + (incf *inch-ptr*)))) -(defmacro unread-buffer () - `(decf *inch-ptr*)) +(declaim (inline unread-buffer)) +(defun unread-buffer () + (decf *inch-ptr*)) +(declaim (inline read-unwind-read-buffer)) (defun read-unwind-read-buffer () ;; Keep contents, but make next (INCH..) return first character. (setq *inch-ptr* 0)) (defun read-buffer-to-string () (subseq *read-buffer* 0 *ouch-ptr*)) + +(defmacro with-read-buffer (() &body body) + `(let* ((*read-buffer* (make-string 128)) + (*ouch-ptr* 0) + (*inch-ptr* 0)) + ,@body)) + +(declaim (inline read-buffer-boundp)) +(defun read-buffer-boundp () + (and (boundp '*read-buffer*) + (boundp '*ouch-ptr*) + (boundp '*inch-ptr*))) + +(defun check-for-recursive-read (stream recursive-p operator-name) + (when (and recursive-p (not (read-buffer-boundp))) + (simple-reader-error + stream + "~A was invoked with RECURSIVE-P being true outside ~ + of a recursive read operation." + `(,operator-name)))) ;;;; READ-PRESERVING-WHITESPACE, READ-DELIMITED-LIST, and READ @@ -395,30 +526,38 @@ (declaim (special *standard-input*)) +;;; Like READ-PRESERVING-WHITESPACE, but doesn't check the read buffer +;;; for being set up properly. +(defun %read-preserving-whitespace (stream eof-error-p eof-value recursive-p) + (if recursive-p + ;; 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)) + ((whitespace[2]p char)) + (t + (let* ((macrofun (get-coerced-cmt-entry char *readtable*)) + (result (multiple-value-list + (funcall macrofun stream char)))) + ;; Repeat if macro returned nothing. + (when result + (return (unless *read-suppress* (car result))))))))) + (let ((*sharp-equal-alist* nil)) + (with-read-buffer () + (%read-preserving-whitespace stream eof-error-p eof-value t))))) + ;;; 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)) + (eof-error-p t) + (eof-value nil) + (recursive-p nil)) #!+sb-doc "Read from STREAM and return the value read, preserving any whitespace that followed the object." - (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-coerced-cmt-entry char *readtable*)) - (result (multiple-value-list - (funcall macrofun stream char)))) - ;; Repeat if macro returned nothing. - (if result (return (car result)))))))) - (let ((*sharp-equal-alist* nil)) - (read-preserving-whitespace stream eof-error-p eof-value t)))) + (check-for-recursive-read stream recursive-p 'read-preserving-whitespace) + (%read-preserving-whitespace stream eof-error-p eof-value recursive-p)) ;;; Return NIL or a list with one thing, depending. ;;; @@ -426,44 +565,51 @@ ;;; past them. We assume CHAR is not whitespace. (defun read-maybe-nothing (stream char) (let ((retval (multiple-value-list - (funcall (get-coerced-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 ())) + (eof-error-p t) + (eof-value nil) + (recursive-p nil)) #!+sb-doc "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 + (check-for-recursive-read stream recursive-p 'read) + (let ((result (%read-preserving-whitespace stream eof-error-p eof-value + recursive-p))) + ;; 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) + ;; CL:READ-PRESERVING-WHITESPACE instead. + (unless (or (eql result eof-value) recursive-p) (let ((next-char (read-char stream nil nil))) - (unless (or (null next-char) - (whitespacep next-char)) - (unread-char next-char stream)))) + (unless (or (null next-char) + (whitespace[2]p 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) + (input-stream *standard-input*) + recursive-p) #!+sb-doc "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)) - (retlist ())) - ((char= char endchar) (nreverse retlist)) - (setq retlist (nconc (read-maybe-nothing input-stream char) retlist)))) + (check-for-recursive-read input-stream recursive-p 'read-delimited-list) + (flet ((%read-delimited-list (endchar input-stream) + (do ((char (flush-whitespace input-stream) + (flush-whitespace input-stream)) + (retlist ())) + ((char= char endchar) + (unless *read-suppress* (nreverse retlist))) + (setq retlist (nconc (read-maybe-nothing input-stream char) + retlist))))) + (declare (inline %read-delimited-list)) + (if recursive-p + (%read-delimited-list endchar input-stream) + (with-read-buffer () + (%read-delimited-list endchar input-stream))))) ;;;; basic readmacro definitions ;;;; @@ -476,64 +622,77 @@ (defun read-comment (stream ignore) (declare (ignore ignore)) - (let ((stream (in-synonym-of 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))) - ((or (eq char :eof) (char= char #\newline)))))) + (handler-bind + ((character-decoding-error + #'(lambda (decoding-error) + (declare (ignorable decoding-error)) + (style-warn + 'sb!kernel::character-decoding-error-in-macro-char-comment + :position (file-position stream) :stream stream) + (invoke-restart 'attempt-resync)))) + (let ((stream (in-synonym-of 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)))) + ;; 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)) (defun read-list (stream ignore) (declare (ignore ignore)) (let* ((thelist (list nil)) - (listtail thelist)) + (listtail thelist)) (do ((firstchar (flush-whitespace stream) (flush-whitespace stream))) - ((char= firstchar #\) ) (cdr thelist)) + ((char= firstchar #\) ) (cdr thelist)) (when (char= firstchar #\.) - (let ((nextchar (read-char stream t))) - (cond ((token-delimiterp nextchar) - (cond ((eq listtail thelist) - (%reader-error - stream - "Nothing appears before . in list.")) - ((whitespacep nextchar) - (setq nextchar (flush-whitespace stream)))) - (rplacd listtail - ;; Return list containing last thing. - (car (read-after-dot stream nextchar))) - (return (cdr thelist))) - ;; Put back NEXTCHAR so that we can read it normally. - (t (unread-char nextchar stream))))) + (let ((nextchar (read-char stream t))) + (cond ((token-delimiterp nextchar) + (cond ((eq listtail thelist) + (unless *read-suppress* + (simple-reader-error + stream + "Nothing appears before . in list."))) + ((whitespace[2]p nextchar) + (setq nextchar (flush-whitespace stream)))) + (rplacd listtail + ;; Return list containing last thing. + (car (read-after-dot stream nextchar))) + (return (cdr thelist))) + ;; Put back NEXTCHAR so that we can read it normally. + (t (unread-char nextchar stream))))) ;; Next thing is not an isolated dot. (let ((listobj (read-maybe-nothing stream firstchar))) - ;; allows the possibility that a comment was read - (when listobj - (rplacd listtail listobj) - (setq listtail listobj)))))) + ;; allows the possibility that a comment was read + (when listobj + (rplacd listtail listobj) + (setq listtail listobj)))))) (defun read-after-dot (stream firstchar) ;; FIRSTCHAR is non-whitespace! (let ((lastobj ())) (do ((char firstchar (flush-whitespace stream))) - ((char= char #\) ) - (%reader-error stream "Nothing appears after . in list.")) + ((char= char #\) ) + (if *read-suppress* + (return-from read-after-dot nil) + (simple-reader-error stream "Nothing appears after . in list."))) ;; See whether there's something there. (setq lastobj (read-maybe-nothing stream char)) (when lastobj (return t))) ;; At least one thing appears after the dot. ;; Check for more than one thing following dot. (do ((lastchar (flush-whitespace stream) - (flush-whitespace stream))) - ((char= lastchar #\) ) lastobj) ;success! + (flush-whitespace stream))) + ((char= lastchar #\) ) lastobj) ;success! ;; Try reading virtual whitespace. - (if (read-maybe-nothing stream lastchar) - (%reader-error stream "More than one object follows . in list."))))) + (if (and (read-maybe-nothing stream lastchar) + (not *read-suppress*)) + (simple-reader-error stream + "More than one object follows . in list."))))) (defun read-string (stream closech) ;; This accumulates chars until it sees same char that invoked it. @@ -541,27 +700,27 @@ (reset-read-buffer) (let ((stream (in-synonym-of 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))) - ((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)) - (if (eq char :eof) - (error 'end-of-file :stream stream))) - (ouch-read-buffer char)))) + (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 (single-escape-p char) (setq char (fast-read-char t))) + (ouch-read-buffer char))) + ;; 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 (single-escape-p char) + (setq char (read-char stream nil :eof)) + (if (eq char :eof) + (error 'end-of-file :stream stream))) + (ouch-read-buffer char)))) (read-buffer-to-string)) (defun read-right-paren (stream ignore) (declare (ignore ignore)) - (%reader-error stream "unmatched close parenthesis")) + (simple-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: @@ -577,90 +736,113 @@ (do ((char firstchar (read-char stream nil *eof-object*)) (colon nil)) ((cond ((eofp char) t) - ((token-delimiterp char) - (unread-char char stream) - t) - (t nil)) + ((token-delimiterp char) + (unread-char char stream) + t) + (t nil)) (values escapes colon)) - (cond ((escapep char) - ;; It can't be a number, even if it's 1\23. - ;; Read next char here, so it won't be casified. - (push *ouch-ptr* escapes) - (let ((nextchar (read-char stream nil *eof-object*))) - (if (eofp nextchar) - (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. - (loop - (let ((ch (read-char stream nil *eof-object*))) - (cond - ((eofp ch) - (reader-eof-error stream "inside extended token")) - ((multiple-escape-p ch) (return)) - ((escapep ch) - (let ((nextchar (read-char stream nil *eof-object*))) - (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) - +char-attr-package-delimiter+) - (not colon)) - (setq colon *ouch-ptr*)) - (ouch-read-buffer char)))))) + (cond ((single-escape-p char) + ;; It can't be a number, even if it's 1\23. + ;; Read next char here, so it won't be casified. + (push *ouch-ptr* escapes) + (let ((nextchar (read-char stream nil *eof-object*))) + (if (eofp nextchar) + (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. + (loop + (let ((ch (read-char stream nil *eof-object*))) + (cond + ((eofp ch) + (reader-eof-error stream "inside extended token")) + ((multiple-escape-p ch) (return)) + ((single-escape-p ch) + (let ((nextchar (read-char stream nil *eof-object*))) + (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-constituent-trait char) + +char-attr-package-delimiter+) + (not colon)) + (setq colon *ouch-ptr*)) + (ouch-read-buffer char)))))) ;;;; character classes ;;; Return the character class for CHAR. -(defmacro char-class (char attable) - `(let ((att (aref ,attable (char-code ,char)))) +;;; +;;; FIXME: why aren't these ATT-getting forms using GET-CAT-ENTRY? +;;; Because we've cached the readtable tables? +(defmacro char-class (char attarray atthash) + `(let ((att (if (typep ,char 'base-char) + (aref ,attarray (char-code ,char)) + (gethash ,char ,atthash +char-attr-constituent+)))) (declare (fixnum att)) - (if (<= att +char-attr-terminating-macro+) - +char-attr-delimiter+ - att))) + (cond + ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+) + ((< att +char-attr-constituent+) att) + (t (setf att (get-constituent-trait ,char)) + (if (= att +char-attr-invalid+) + (simple-reader-error stream "invalid constituent") + att))))) ;;; 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)))) +(defmacro char-class2 (char attarray atthash) + `(let ((att (if (typep ,char 'base-char) + (aref ,attarray (char-code ,char)) + (gethash ,char ,atthash +char-attr-constituent+)))) (declare (fixnum att)) - (if (<= att +char-attr-terminating-macro+) - +char-attr-delimiter+ - (if (digit-char-p ,char *read-base*) - +char-attr-constituent-digit+ - (if (= att +char-attr-constituent-digit+) - +char-attr-constituent+ - att))))) + (cond + ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+) + ((< att +char-attr-constituent+) att) + (t (setf att (get-constituent-trait ,char)) + (cond + ((digit-char-p ,char *read-base*) +char-attr-constituent-digit+) + ((= att +char-attr-constituent-digit+) +char-attr-constituent+) + ((= att +char-attr-invalid+) + (simple-reader-error stream "invalid constituent")) + (t 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.) -(defmacro char-class3 (char attable) - `(let ((att (aref ,attable (char-code ,char)))) +(defmacro char-class3 (char attarray atthash) + `(let ((att (if (typep ,char 'base-char) + (aref ,attarray (char-code ,char)) + (gethash ,char ,atthash +char-attr-constituent+)))) (declare (fixnum att)) - (if possibly-rational - (setq possibly-rational - (or (digit-char-p ,char *read-base*) - (= att +char-attr-constituent-slash+)))) - (if possibly-float - (setq possibly-float - (or (digit-char-p ,char 10) - (= 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*) - +char-attr-constituent-digit+ - +char-attr-constituent+) - att)))) + (cond + ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+) + ((< att +char-attr-constituent+) att) + (t (setf att (get-constituent-trait ,char)) + (when possibly-rational + (setq possibly-rational + (or (digit-char-p ,char *read-base*) + (= att +char-attr-constituent-slash+)))) + (when possibly-float + (setq possibly-float + (or (digit-char-p ,char 10) + (= att +char-attr-constituent-dot+)))) + (cond + ((digit-char-p ,char (max *read-base* 10)) + (if (digit-char-p ,char *read-base*) + (if (= att +char-attr-constituent-expt+) + +char-attr-constituent-digit-or-expt+ + +char-attr-constituent-digit+) + +char-attr-constituent-decimal-digit+)) + ((= att +char-attr-invalid+) + (simple-reader-error stream "invalid constituent")) + (t att)))))) ;;;; token fetching @@ -680,47 +862,54 @@ (let ((case (readtable-case *readtable*))) (cond ((and (null escapes) (eq case :upcase)) - (dotimes (i *ouch-ptr*) - (setf (schar *read-buffer* i) - (char-upcase (schar *read-buffer* i))))) + ;; Pull the special variable access out of the loop. + (let ((buffer *read-buffer*)) + (dotimes (i *ouch-ptr*) + (declare (optimize (sb!c::insert-array-bounds-checks 0))) + (setf (schar buffer i) (char-upcase (schar buffer i)))))) ((eq case :preserve)) (t (macrolet ((skip-esc (&body body) - `(do ((i (1- *ouch-ptr*) (1- i)) - (escapes escapes)) - ((minusp i)) - (declare (fixnum i)) - (when (or (null escapes) - (let ((esc (first escapes))) - (declare (fixnum esc)) - (cond ((< esc i) t) - (t - (aver (= esc i)) - (pop escapes) - nil)))) - (let ((ch (schar *read-buffer* i))) - ,@body))))) - (flet ((lower-em () - (skip-esc (setf (schar *read-buffer* i) (char-downcase ch)))) - (raise-em () - (skip-esc (setf (schar *read-buffer* i) (char-upcase ch))))) - (ecase case - (:upcase (raise-em)) - (:downcase (lower-em)) - (:invert - (let ((all-upper t) - (all-lower t)) - (skip-esc - (when (both-case-p ch) - (if (upper-case-p ch) - (setq all-lower nil) - (setq all-upper nil)))) - (cond (all-lower (raise-em)) - (all-upper (lower-em)))))))))))) + `(do ((i (1- *ouch-ptr*) (1- i)) + (buffer *read-buffer*) + (escapes escapes)) + ((minusp i)) + (declare (fixnum i) + (optimize (sb!c::insert-array-bounds-checks 0))) + (when (or (null escapes) + (let ((esc (first escapes))) + (declare (fixnum esc)) + (cond ((< esc i) t) + (t + (aver (= esc i)) + (pop escapes) + nil)))) + (let ((ch (schar buffer i))) + ,@body))))) + (flet ((lower-em () + (skip-esc (setf (schar buffer i) (char-downcase ch)))) + (raise-em () + (skip-esc (setf (schar buffer i) (char-upcase ch))))) + (ecase case + (:upcase (raise-em)) + (:downcase (lower-em)) + (:invert + (let ((all-upper t) + (all-lower t)) + (skip-esc + (when (both-case-p ch) + (if (upper-case-p ch) + (setq all-lower nil) + (setq all-upper nil)))) + (cond (all-lower (raise-em)) + (all-upper (lower-em)))))))))))) + +(defvar *reader-package* nil) (defun read-token (stream firstchar) #!+sb-doc - "This function is just an fsm that recognizes numbers and symbols." + "Default readmacro function. Handles numbers, symbols, and SBCL's +extended :: syntax." ;; 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 @@ -731,315 +920,388 @@ (when *read-suppress* (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) - (possibly-float t) - (escapes ())) + (let ((attribute-array (character-attribute-array *readtable*)) + (attribute-hash-table (character-attribute-hash-table *readtable*)) + (package-designator nil) + (colons 0) + (possibly-rational t) + (seen-digit-or-expt nil) + (possibly-float t) + (was-possibly-float nil) + (escapes ()) + (seen-multiple-escapes nil)) (reset-read-buffer) (prog ((char firstchar)) - (case (char-class3 char attribute-table) - (#.+char-attr-constituent-sign+ (go SIGN)) - (#.+char-attr-constituent-digit+ (go LEFTDIGIT)) - (#.+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))) + (case (char-class3 char attribute-array attribute-hash-table) + (#.+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-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-invalid+ (simple-reader-error stream + "invalid constituent")) + ;; can't have eof, whitespace, or terminating macro as first char! + (t (go SYMBOL))) 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) - (#.+char-attr-constituent-digit+ (go LEFTDIGIT)) - (#.+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))) + possibly-float t) + (case (char-class3 char attribute-array attribute-hash-table) + (#.+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-single-escape+ (go SINGLE-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}+" (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-dot+ (if possibly-float - (go MIDDLEDOT) - (go SYMBOL))) - (#.+char-attr-constituent-expt+ (go EXPONENT)) - (#.+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))) + (setq was-possibly-float possibly-float) + (case (char-class3 char attribute-array attribute-hash-table) + (#.+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-single-escape+ (go SINGLE-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-array attribute-hash-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-single-escape+ (go SINGLE-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-array attribute-hash-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-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) 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) - (#.+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)))) - (#.+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}+" + (make-integer)))) + (case (char-class char attribute-array attribute-hash-table) + (#.+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)))) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) + RIGHTDIGIT ; saw "[sign] {decimal-digit}* dot {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-float stream))) - (case (char-class char attribute-table) - (#.+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))) + (case (char-class char attribute-array attribute-hash-table) + (#.+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-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) 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) - (#.+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))) + (case (char-class char attribute-array attribute-hash-table) + (#.+char-attr-constituent-digit+ (go RIGHTDIGIT)) + (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (t (go SYMBOL))) 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) - (#.+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))) + (unless char (simple-reader-error stream "dot context error")) + (case (char-class char attribute-array attribute-hash-table) + (#.+char-attr-constituent-digit+ (go RIGHTDIGIT)) + (#.+char-attr-constituent-dot+ (go DOTS)) + (#.+char-attr-delimiter+ (simple-reader-error stream + "dot context error")) + (#.+char-attr-single-escape+ (go SINGLE-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)) - (case (char-class char attribute-table) - (#.+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))) + (setq possibly-float t) + (case (char-class char attribute-array attribute-hash-table) + (#.+char-attr-constituent-sign+ (go EXPTSIGN)) + (#.+char-attr-constituent-digit+ (go EXPTDIGIT)) + (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) 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) - (#.+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))) + (case (char-class char attribute-array attribute-hash-table) + (#.+char-attr-constituent-digit+ (go EXPTDIGIT)) + (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) EXPTDIGIT ; got to EXPONENT, saw "[sign] {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-float stream))) - (case (char-class char attribute-table) - (#.+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))) + (case (char-class char attribute-array attribute-hash-table) + (#.+char-attr-constituent-digit+ (go EXPTDIGIT)) + (#.+char-attr-delimiter+ + (unread-char char stream) + (return (make-float stream))) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) 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) - (#.+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))) + (case (char-class2 char attribute-array attribute-hash-table) + (#.+char-attr-constituent-digit+ (go RATIODIGIT)) + (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) RATIODIGIT ; saw "[sign] {digit}+ slash {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-ratio stream))) - (case (char-class2 char attribute-table) - (#.+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))) + (case (char-class2 char attribute-array attribute-hash-table) + (#.+char-attr-constituent-digit+ (go RATIODIGIT)) + (#.+char-attr-delimiter+ + (unread-char char stream) + (return (make-ratio stream))) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) 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) - (#.+char-attr-constituent-dot+ (go DOTS)) - (#.+char-attr-delimiter+ - (unread-char char stream) - (%reader-error stream "too many dots")) - (#.+char-attr-escape+ (go ESCAPE)) - (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) - (#.+char-attr-package-delimiter+ (go COLON)) - (t (go SYMBOL))) + (unless char (simple-reader-error stream "too many dots")) + (case (char-class char attribute-array attribute-hash-table) + (#.+char-attr-constituent-dot+ (go DOTS)) + (#.+char-attr-delimiter+ + (unread-char char stream) + (simple-reader-error stream "too many dots")) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) SYMBOL ; not a dot, dots, or number (let ((stream (in-synonym-of stream))) - (if (ansi-stream-p stream) - (prepare-for-fast-read-char stream - (prog () - SYMBOL-LOOP - (ouch-read-buffer char) - (setq char (fast-read-char nil nil)) - (unless char (go RETURN-SYMBOL)) - (case (char-class char attribute-table) - (#.+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 - (prog () - SYMBOL-LOOP - (ouch-read-buffer char) - (setq char (stream-read-char stream)) - (when (eq char :eof) (go RETURN-SYMBOL)) - (case (char-class char attribute-table) - (#.+char-attr-escape+ (go ESCAPE)) - (#.+char-attr-delimiter+ (stream-unread-char stream char) - (go RETURN-SYMBOL)) - (#.+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. + (if (ansi-stream-p stream) + (prepare-for-fast-read-char stream + (prog () + SYMBOL-LOOP + (ouch-read-buffer char) + (setq char (fast-read-char nil nil)) + (unless char (go RETURN-SYMBOL)) + (case (char-class char attribute-array attribute-hash-table) + (#.+char-attr-single-escape+ (done-with-fast-read-char) + (go SINGLE-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))))) + ;; CLOS stream + (prog () + SYMBOL-LOOP + (ouch-read-buffer char) + (setq char (read-char stream nil :eof)) + (when (eq char :eof) (go RETURN-SYMBOL)) + (case (char-class char attribute-array attribute-hash-table) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-delimiter+ (unread-char char stream) + (go RETURN-SYMBOL)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL-LOOP)))))) + SINGLE-ESCAPE ; saw a single-escape + ;; Don't put the escape character 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")) - (push *ouch-ptr* escapes) - (ouch-read-buffer nextchar)) + (unless nextchar + (reader-eof-error stream "after single-escape character")) + (push *ouch-ptr* escapes) + (ouch-read-buffer nextchar)) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) - (case (char-class char attribute-table) - (#.+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))) + (case (char-class char attribute-array attribute-hash-table) + (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) + (#.+char-attr-single-escape+ (go SINGLE-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))) - (push *ouch-ptr* escapes) - (ouch-read-buffer char)) + ((multiple-escape-p char)) + (if (single-escape-p char) (setq char (read-char stream t))) + (push *ouch-ptr* escapes) + (ouch-read-buffer char)) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) - (case (char-class char attribute-table) - (#.+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))) + (case (char-class char attribute-array attribute-hash-table) + (#.+char-attr-delimiter+ (unread-char char stream) (go RETURN-SYMBOL)) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go COLON)) + (t (go SYMBOL))) COLON (casify-read-buffer escapes) (unless (zerop colons) - (%reader-error stream "too many colons in ~S" - (read-buffer-to-string))) + (simple-reader-error stream + "too many colons in ~S" + (read-buffer-to-string))) (setq colons 1) (setq package-designator - (if (plusp *ouch-ptr*) - ;; FIXME: It seems inefficient to cons up a package - ;; designator string every time we read a symbol with an - ;; explicit package prefix. Perhaps we could implement - ;; a FIND-PACKAGE* function analogous to INTERN* - ;; and friends? - (read-buffer-to-string) - *keyword-package*)) + (if (plusp *ouch-ptr*) + ;; FIXME: It seems inefficient to cons up a package + ;; designator string every time we read a symbol with an + ;; explicit package prefix. Perhaps we could implement + ;; a FIND-PACKAGE* function analogous to INTERN* + ;; and friends? + (read-buffer-to-string) + (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) - (#.+char-attr-delimiter+ - (unread-char char stream) - (%reader-error stream - "illegal terminating character after a colon: ~S" - char)) - (#.+char-attr-escape+ (go ESCAPE)) - (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) - (#.+char-attr-package-delimiter+ (go INTERN)) - (t (go SYMBOL))) + (case (char-class char attribute-array attribute-hash-table) + (#.+char-attr-delimiter+ + (unread-char char stream) + (simple-reader-error stream + "illegal terminating character after a colon: ~S" + char)) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go INTERN)) + (t (go SYMBOL))) INTERN (setq colons 2) (setq char (read-char stream nil nil)) (unless char - (reader-eof-error stream "after reading a colon")) - (case (char-class char attribute-table) - (#.+char-attr-delimiter+ - (unread-char char stream) - (%reader-error stream - "illegal terminating character after a colon: ~S" - char)) - (#.+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)) - (t (go SYMBOL))) + (reader-eof-error stream "after reading a colon")) + (case (char-class char attribute-array attribute-hash-table) + (#.+char-attr-delimiter+ + (unread-char char stream) + (if package-designator + (let* ((*reader-package* (%find-package-or-lose package-designator))) + (return (read stream t nil t))) + (simple-reader-error stream + "illegal terminating character after a double-colon: ~S" + char))) + (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ + (simple-reader-error stream + "too many colons after ~S name" + package-designator)) + (t (go SYMBOL))) RETURN-SYMBOL (casify-read-buffer escapes) (let ((found (if package-designator - (find-package package-designator) - (sane-package)))) - (unless found - (error 'reader-package-error :stream stream - :format-arguments (list package-designator) - :format-control "package ~S not found")) - - (if (or (zerop colons) (= colons 2) (eq found *keyword-package*)) - (return (intern* *read-buffer* *ouch-ptr* found)) - (multiple-value-bind (symbol test) - (find-symbol* *read-buffer* *ouch-ptr* found) - (when (eq test :external) (return symbol)) - (let ((name (read-buffer-to-string))) - (with-simple-restart (continue "Use symbol anyway.") - (error 'reader-package-error :stream stream - :format-arguments (list name (package-name found)) - :format-control - (if test - "The symbol ~S is not external in the ~A package." - "Symbol ~S not found in the ~A package."))) - (return (intern name found))))))))) + (or (find-package package-designator) + (error 'simple-reader-package-error + :package package-designator + :stream stream + :format-control "Package ~A does not exist." + :format-arguments (list package-designator))) + (or *reader-package* (sane-package))))) + (if (or (zerop colons) (= colons 2) (eq found *keyword-package*)) + (return (intern* *read-buffer* *ouch-ptr* found)) + (multiple-value-bind (symbol test) + (find-symbol* *read-buffer* *ouch-ptr* found) + (when (eq test :external) (return symbol)) + (let ((name (read-buffer-to-string))) + (with-simple-restart (continue "Use symbol anyway.") + (error 'simple-reader-package-error + :package found + :stream stream + :format-arguments (list name (package-name found)) + :format-control + (if test + "The symbol ~S is not external in the ~A package." + "Symbol ~S not found in the ~A package."))) + (return (intern name found))))))))) ;;; for semi-external use: ;;; @@ -1049,12 +1311,12 @@ (defun read-extended-token (stream &optional (*readtable* *readtable*)) (let ((first-char (read-char stream nil nil t))) (cond (first-char - (multiple-value-bind (escapes colon) + (multiple-value-bind (escapes colon) (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))))) + (casify-read-buffer escapes) + (values (read-buffer-to-string) (not (null escapes)) colon))) + (t + (values "" nil nil))))) ;;; for semi-external use: ;;; @@ -1099,20 +1361,20 @@ #!+sb-doc "the largest fixnum power of the base for MAKE-INTEGER") (declaim (simple-vector *integer-reader-safe-digits* - *integer-reader-base-power*)) + *integer-reader-base-power*)) #| (defun !cold-init-integer-reader () (do ((base 2 (1+ base))) ((> base 36)) (let ((digits - (do ((fix (truncate most-positive-fixnum base) - (truncate fix base)) - (digits 0 (1+ digits))) - ((zerop fix) digits)))) + (do ((fix (truncate most-positive-fixnum base) + (truncate fix base)) + (digits 0 (1+ digits))) + ((zerop fix) digits)))) (setf (aref *integer-reader-safe-digits* base) - digits - (aref *integer-reader-base-power* base) - (expt base digits))))) + digits + (aref *integer-reader-base-power* base) + (expt base digits))))) |# (defun make-integer () @@ -1120,145 +1382,126 @@ "Minimizes bignum-fixnum multiplies by reading a 'safe' number of digits, then multiplying by a power of the base and adding." (let* ((base *read-base*) - (digits-per (aref *integer-reader-safe-digits* base)) - (base-power (aref *integer-reader-base-power* base)) - (negativep nil) - (number 0)) + (digits-per (aref *integer-reader-safe-digits* base)) + (base-power (aref *integer-reader-base-power* base)) + (negativep nil) + (number 0)) (declare (type index digits-per base-power)) (read-unwind-read-buffer) (let ((char (inch-read-buffer))) (cond ((char= char #\-) - (setq negativep t)) - ((char= char #\+)) - (t (unread-buffer)))) + (setq negativep t)) + ((char= char #\+)) + (t (unread-buffer)))) (loop (let ((num 0)) (declare (type index num)) (dotimes (digit digits-per) - (let* ((ch (inch-read-buffer))) - (cond ((or (eofp ch) (char= ch #\.)) - (return-from make-integer - (let ((res - (if (zerop number) num - (+ num (* number - (expt base digit)))))) - (if negativep (- res) res)))) - (t (setq num (+ (digit-char-p ch base) - (the index (* num base)))))))) + (let* ((ch (inch-read-buffer))) + (cond ((or (eofp ch) (char= ch #\.)) + (return-from make-integer + (let ((res + (if (zerop number) num + (+ num (* number + (expt base digit)))))) + (if negativep (- res) res)))) + (t (setq num (+ (digit-char-p ch base) + (the index (* num base)))))))) (setq number (+ num (* number base-power))))))) +(defun truncate-exponent (exponent number divisor) + "Truncate exponent if it's too large for a float" + ;; Work with base-2 logarithms to avoid conversions to floats, + ;; and convert to base-10 conservatively at the end. + ;; Use the least positive float, because denormalized exponent + ;; can be larger than normalized. + (let* ((max-exponent + #!-long-float + (+ sb!vm:double-float-digits sb!vm:double-float-bias)) + (number-magnitude (integer-length number)) + (divisor-magnitude (1- (integer-length divisor))) + (magnitude (- number-magnitude divisor-magnitude))) + (if (minusp exponent) + (max exponent (ceiling (- (+ max-exponent magnitude)) + #.(floor (log 10 2)))) + (min exponent (floor (- max-exponent magnitude) + #.(floor (log 10 2))))))) + (defun make-float (stream) ;; Assume that the contents of *read-buffer* are a legal float, with nothing ;; else after it. (read-unwind-read-buffer) (let ((negative-fraction nil) - (number 0) - (divisor 1) - (negative-exponent nil) - (exponent 0) - (float-char ()) - (char (inch-read-buffer))) + (number 0) + (divisor 1) + (negative-exponent nil) + (exponent 0) + (float-char ()) + (char (inch-read-buffer))) (if (cond ((char= char #\+) t) - ((char= char #\-) (setq negative-fraction t))) - ;; Flush it. - (setq char (inch-read-buffer))) + ((char= char #\-) (setq negative-fraction t))) + ;; Flush it. + (setq char (inch-read-buffer))) ;; Read digits before the dot. (do* ((ch char (inch-read-buffer)) - (dig (digit-char-p ch) (digit-char-p ch))) - ((not dig) (setq char ch)) + (dig (digit-char-p ch) (digit-char-p ch))) + ((not dig) (setq char ch)) (setq number (+ (* number 10) dig))) ;; Deal with the dot, if it's there. (when (char= char #\.) (setq char (inch-read-buffer)) ;; Read digits after the dot. (do* ((ch char (inch-read-buffer)) - (dig (and (not (eofp ch)) (digit-char-p ch)) - (and (not (eofp ch)) (digit-char-p ch)))) - ((not dig) (setq char ch)) - (setq divisor (* divisor 10)) - (setq number (+ (* number 10) dig)))) + (dig (and (not (eofp ch)) (digit-char-p ch)) + (and (not (eofp ch)) (digit-char-p ch)))) + ((not dig) (setq char ch)) + (setq divisor (* divisor 10)) + (setq number (+ (* number 10) dig)))) ;; Is there an exponent letter? (cond ((eofp char) - ;; If not, we've read the whole number. - (let ((num (make-float-aux number divisor - *read-default-float-format* - stream))) - (return-from make-float (if negative-fraction (- num) num)))) - ((exponent-letterp char) - (setq float-char char) - ;; Build exponent. - (setq char (inch-read-buffer)) - ;; Check leading sign. - (if (cond ((char= char #\+) t) - ((char= char #\-) (setq negative-exponent t))) - ;; Flush sign. - (setq char (inch-read-buffer))) - ;; Read digits for exponent. - (do* ((ch char (inch-read-buffer)) - (dig (and (not (eofp ch)) (digit-char-p ch)) - (and (not (eofp ch)) (digit-char-p ch)))) - ((not dig) - (setq exponent (if negative-exponent (- exponent) exponent))) - (setq exponent (+ (* exponent 10) dig))) - ;; 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) - (#\F 'single-float) - (#\D 'double-float) - (#\L 'long-float))) - num) - ;; 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 sb!xc:least-positive-normalized-short-float 10s0) - (log sb!xc:most-positive-short-float 10s0))) - (single-float - (values - (log sb!xc:least-positive-normalized-single-float 10f0) - (log sb!xc:most-positive-single-float 10f0))) - (double-float - (values - (log sb!xc:least-positive-normalized-double-float 10d0) - (log sb!xc:most-positive-double-float 10d0))) - (long-float - (values - (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) - (floor (- max-expo exponent))) - (t - 0)))) - (incf exponent correction) - (setf number (/ number (expt 10 correction))) - (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 (bug "bad fallthrough in floating point reader"))))) + ;; If not, we've read the whole number. + (let ((num (make-float-aux number divisor + *read-default-float-format* + stream))) + (return-from make-float (if negative-fraction (- num) num)))) + ((exponent-letterp char) + (setq float-char char) + ;; Build exponent. + (setq char (inch-read-buffer)) + ;; Check leading sign. + (if (cond ((char= char #\+) t) + ((char= char #\-) (setq negative-exponent t))) + ;; Flush sign. + (setq char (inch-read-buffer))) + ;; Read digits for exponent. + (do* ((ch char (inch-read-buffer)) + (dig (and (not (eofp ch)) (digit-char-p ch)) + (and (not (eofp ch)) (digit-char-p ch)))) + ((not dig) + (setq exponent (if negative-exponent (- exponent) exponent))) + (setq exponent (+ (* exponent 10) dig))) + ;; 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) + (#\F 'single-float) + (#\D 'double-float) + (#\L 'long-float))) + (exponent (truncate-exponent exponent number divisor)) + (result (make-float-aux (* (expt 10 exponent) number) + divisor float-format stream))) + (return-from make-float + (if negative-fraction (- result) result)))) + (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")))) + :error c :stream stream + :format-control "failed to build float from ~a" + :format-arguments (list (read-buffer-to-string)))))) (defun make-ratio (stream) ;; Assume *READ-BUFFER* contains a legal ratio. Build the number from @@ -1269,153 +1512,138 @@ (read-unwind-read-buffer) (setq char (inch-read-buffer)) (cond ((char= char #\+) - (setq char (inch-read-buffer))) - ((char= char #\-) - (setq char (inch-read-buffer)) - (setq negative-number t))) + (setq char (inch-read-buffer))) + ((char= char #\-) + (setq char (inch-read-buffer)) + (setq negative-number t))) ;; Get numerator. (do* ((ch char (inch-read-buffer)) - (dig (digit-char-p ch *read-base*) - (digit-char-p ch *read-base*))) - ((not dig)) - (setq numerator (+ (* numerator *read-base*) dig))) + (dig (digit-char-p ch *read-base*) + (digit-char-p ch *read-base*))) + ((not dig)) + (setq numerator (+ (* numerator *read-base*) dig))) ;; Get denominator. (do* ((ch (inch-read-buffer) (inch-read-buffer)) - (dig ())) - ((or (eofp ch) (not (setq dig (digit-char-p ch *read-base*))))) - (setq denominator (+ (* denominator *read-base*) dig))) + (dig ())) + ((or (eofp ch) (not (setq dig (digit-char-p ch *read-base*))))) + (setq denominator (+ (* denominator *read-base*) dig))) (let ((num (handler-case - (/ numerator denominator) - (arithmetic-error (c) - (error 'reader-impossible-number-error - :error c :stream stream - :format-control "failed to build ratio"))))) + (/ 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 - -(defun make-char-dispatch-table () - (make-array char-code-limit :initial-element #'dispatch-char-error)) +;;;; General reader for dispatch macros (defun dispatch-char-error (stream sub-char ignore) (declare (ignore ignore)) (if *read-suppress* (values) - (%reader-error stream "no dispatch function defined for ~S" sub-char))) - -(defun make-dispatch-macro-character (char &optional - (non-terminating-p nil) - (rt *readtable*)) - #!+sb-doc - "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 "The dispatch character ~S already exists." char)) - (t - (setf (dispatch-tables rt) - (push (cons char (make-char-dispatch-table)) dalist))))) - t) - -(defun set-dispatch-macro-character (disp-char sub-char function - &optional (rt *readtable*)) - #!+sb-doc - "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 - (setf (elt (the simple-vector (cdr dpair)) - (char-code sub-char)) - (coerce function 'function)) - (error "~S is not a dispatch char." disp-char)))) - -(defun get-dispatch-macro-character (disp-char sub-char - &optional (rt *readtable*)) - #!+sb-doc - "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)))) + (simple-reader-error stream + "no dispatch function defined for ~S" + sub-char))) (defun read-dispatch-char (stream char) ;; Read some digits. (let ((numargp nil) - (numarg 0) - (sub-char ())) + (numarg 0) + (sub-char ())) (do* ((ch (read-char stream nil *eof-object*) - (read-char stream nil *eof-object*)) - (dig ())) - ((or (eofp ch) - (not (setq dig (digit-char-p ch)))) - ;; Take care of the extra char. - (if (eofp ch) - (reader-eof-error stream "inside dispatch character") - (setq sub-char (char-upcase ch)))) + (read-char stream nil *eof-object*)) + (dig ())) + ((or (eofp ch) + (not (setq dig (digit-char-p ch)))) + ;; Take care of the extra char. + (if (eofp ch) + (reader-eof-error stream "inside dispatch character") + (setq sub-char (char-upcase ch)))) (setq numargp t) (setq numarg (+ (* numarg 10) dig))) ;; Look up the function and call it. (let ((dpair (find char (dispatch-tables *readtable*) - :test #'char= :key #'car))) + :test #'char= :key #'car))) (if dpair - (funcall (the function - (elt (the simple-vector (cdr dpair)) - (char-code sub-char))) - stream sub-char (if numargp numarg nil)) - (%reader-error stream "no dispatch table for dispatch char"))))) + (funcall (the function + (gethash sub-char (cdr dpair) #'dispatch-char-error)) + stream sub-char (if numargp numarg nil)) + (simple-reader-error stream + "no dispatch table for dispatch char"))))) ;;;; READ-FROM-STRING -;;; FIXME: Is it really worth keeping this pool? -(defvar *read-from-string-spares* () - #!+sb-doc - "A resource of string streams for Read-From-String.") - -(defun read-from-string (string &optional eof-error-p eof-value - &key (start 0) end - preserve-whitespace) +(defun maybe-note-read-from-string-signature-issue (eof-error-p) + ;; The interface is so unintuitive that we explicitly check for the common + ;; error. + (when (member eof-error-p '(:start :end :preserve-whitespace)) + (style-warn "~@<~S as EOF-ERROR-P argument to ~S: probable error. ~ + Two optional arguments must be provided before the ~ + first keyword argument.~:@>" + eof-error-p 'read-from-string) + t)) + +(declaim (ftype (sfunction (string t t index (or null index) t) (values t index)) + %read-from-string)) +(defun %read-from-string (string eof-error-p eof-value start end preserve-whitespace) + (with-array-data ((string string :offset-var offset) + (start start) + (end end) + :check-fill-pointer t) + (let ((stream (make-string-input-stream string start end))) + (values (if preserve-whitespace + (%read-preserving-whitespace stream eof-error-p eof-value nil) + (read stream eof-error-p eof-value)) + (- (string-input-stream-current stream) offset))))) + +(defun read-from-string (string &optional (eof-error-p t) eof-value + &key (start 0) end preserve-whitespace) #!+sb-doc "The characters of string are successively given to the lisp reader 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)))) - (unless *read-from-string-spares* - (push (internal-make-string-input-stream "" 0 0) - *read-from-string-spares*)) - (let ((stream (pop *read-from-string-spares*))) - (setf (string-input-stream-string stream) string) - (setf (string-input-stream-current stream) start) - (setf (string-input-stream-end stream) end) - (unwind-protect - (values (if preserve-whitespace - (read-preserving-whitespace stream eof-error-p eof-value) - (read stream eof-error-p eof-value)) - (string-input-stream-current stream)) - (push stream *read-from-string-spares*))))) + (maybe-note-read-from-string-signature-issue eof-error-p) + (%read-from-string string eof-error-p eof-value start end preserve-whitespace)) + +(define-compiler-macro read-from-string (&whole form string &rest args) + ;; Check this at compile-time, and rewrite it so we're silent at runtime. + (destructuring-bind (&optional (eof-error-p t) eof-value &rest keys) + args + (cond ((maybe-note-read-from-string-signature-issue eof-error-p) + `(read-from-string ,string t ,eof-value ,@keys)) + (t + (let* ((start (gensym "START")) + (end (gensym "END")) + (preserve-whitespace (gensym "PRESERVE-WHITESPACE")) + bind seen ignore) + (do () + ((not (cdr keys)) + ;; Odd number of keys, punt. + (when keys (return-from read-from-string form))) + (let* ((key (pop keys)) + (value (pop keys)) + (var (case key + (:start start) + (:end end) + (:preserve-whitespace preserve-whitespace) + (otherwise + (return-from read-from-string form))))) + (when (member key seen) + (setf var (gensym "IGNORE")) + (push var ignore)) + (push key seen) + (push (list var value) bind))) + (dolist (default (list (list start 0) + (list end nil) + (list preserve-whitespace nil))) + (unless (assoc (car default) bind) + (push default bind))) + (once-only ((string string)) + `(let ,(nreverse bind) + ,@(when ignore `((declare (ignore ,@ignore)))) + (%read-from-string ,string ,eof-error-p ,eof-value + ,start ,end ,preserve-whitespace)))))))) ;;;; PARSE-INTEGER @@ -1426,60 +1654,60 @@ whitespace characters and then tries to parse an integer. The radix parameter must be between 2 and 36." (macrolet ((parse-error (format-control) - `(error 'simple-parse-error - :format-control ,format-control - :format-arguments (list string)))) - (with-array-data ((string string) - (start start) - (end (or end (length string)))) + `(error 'simple-parse-error + :format-control ,format-control + :format-arguments (list string)))) + (with-array-data ((string string :offset-var offset) + (start start) + (end end) + :check-fill-pointer t) (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) - (do ((jndex (1+ index) (1+ jndex))) - ((= jndex end)) - (declare (fixnum jndex)) - (unless (whitespacep (char string jndex)) - (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))))) + ((= 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 (whitespace[1]p (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)) + ((whitespace[1]p char) + (loop + (incf index) + (when (= index end) (return)) + (unless (whitespace[1]p (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 (defun !reader-cold-init () - (!cold-init-read-buffer) - (!cold-init-secondary-attribute-table) + (!cold-init-constituent-trait-table) (!cold-init-standard-readtable) ;; FIXME: This was commented out, but should probably be restored. #+nil (!cold-init-integer-reader))