X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Freader.lisp;h=8f885fa97279d74e279b25087a6cf9314b0b0ed9;hb=HEAD;hp=08d6ea30f8a913c2174db52a85eec0257e484ef9;hpb=cf0b72cd4052a09b9a305081524bd44e2948c1e5;p=sbcl.git diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 08d6ea3..8f885fa 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -24,12 +24,12 @@ (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 @@ -49,41 +49,44 @@ :stream stream :context context)) -(defun %reader-error (stream control &rest args) - (error 'reader-error +;;; 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 - `(if (typep ,char 'base-char) - (elt (character-attribute-array ,rt) (char-code ,char)) - (gethash ,char (character-attribute-hash-table ,rt) - +char-attr-constituent+))) +(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*)) + (declare (readtable rt)) (if (typep char 'base-char) (setf (elt (character-attribute-array rt) (char-code char)) newvalue) - ;; FIXME: could REMHASH if we're setting to - ;; +CHAR-ATTR-CONSTITUENT+ - (setf (gethash char (character-attribute-hash-table rt)) 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) - `(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. - (gethash ,char (character-macro-hash-table ,readtable) nil)))) +(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, @@ -95,17 +98,15 @@ #'read-token))) (defun set-cmt-entry (char new-value-designator &optional (rt *readtable*)) - (if (typep char 'base-char) - (setf (svref (character-macro-array rt) (char-code char)) - (and new-value-designator - (%coerce-callable-to-fun new-value-designator))) - (setf (gethash char (character-macro-hash-table rt)) - (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. @@ -114,29 +115,35 @@ ;;; predicates for testing character attributes +#!-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". -#!-sb-fluid (declaim (inline whitespace[1]p whitespace[2]p)) (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*)) - `(test-attribute ,char +char-attr-constituent+ ,rt)) +(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 single-escape-p (char &optional (rt '*readtable*)) - `(test-attribute ,char +char-attr-single-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+)) ;;;; constituent traits (see ANSI 2.1.4.2) @@ -179,18 +186,31 @@ return-char-code rubout-char-code)) (!set-constituent-trait (code-char c) +char-attr-invalid+))) -(defmacro get-constituent-trait (char) - `(if (typep ,char 'base-char) - (elt *constituent-trait-table* (char-code ,char)) - +char-attr-constituent+)) +(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 (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) +(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-array really-to-readtable) @@ -215,11 +235,12 @@ 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." + (assert-not-standard-readtable to-readtable 'set-syntax-from-char) (let ((really-from-readtable (or from-readtable *standard-readtable*))) (let ((att (get-cat-entry from-char really-from-readtable)) (mac (get-raw-cmt-entry from-char really-from-readtable)) @@ -229,27 +250,31 @@ standard Lisp readtable when NIL." :test #'char= :key #'car))) (set-cat-entry to-char att to-readtable) (set-cmt-entry to-char mac to-readtable) - (when from-dpair - (cond - (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)) + (cond ((and (not from-dpair) (not to-dpair))) + ((and (not from-dpair) to-dpair) (setf (dispatch-tables to-readtable) - (push pair (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*)) + (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*))) + (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+) @@ -257,31 +282,87 @@ standard Lisp readtable when NIL." (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*)) + (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))) + (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 @@ -319,98 +400,78 @@ standard Lisp readtable when NIL." ;;;; 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-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 *standard-readtable*) - (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 (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))) - -;;; 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 *read-buffer*)) (new-length (* 2 rbl)) (new-buffer (make-string new-length))) - (setq *read-buffer* (replace new-buffer *read-buffer*)) - (setq *read-buffer-length* new-length))) - -(defun inchpeek-read-buffer () - (if (>= (the fixnum *inch-ptr*) (the fixnum *ouch-ptr*)) - *eof-object* - (elt *read-buffer* *inch-ptr*))) + (setq *read-buffer* (replace new-buffer *read-buffer*)))) (defun inch-read-buffer () (if (>= *inch-ptr* *ouch-ptr*) @@ -419,9 +480,11 @@ standard Lisp readtable when NIL." (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)) @@ -429,17 +492,25 @@ standard Lisp readtable when NIL." (defun read-buffer-to-string () (subseq *read-buffer* 0 *ouch-ptr*)) -(defmacro with-reader ((&optional recursive-p) &body body) - #!+sb-doc - "If RECURSIVE-P is NIL, bind *READER-BUFFER* and its subservient -variables to allow for nested and thread safe reading." - `(if ,recursive-p - (progn ,@body) - (let* ((*read-buffer* (make-string 128)) - (*read-buffer-length* 128) - (*ouch-ptr* 0) - (*inch-ptr* 0)) - ,@body))) +(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 @@ -455,17 +526,10 @@ variables to allow for nested and thread safe reading." (declaim (special *standard-input*)) -;;; 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 - "Read from STREAM and return the value read, preserving any whitespace - that followed the object." - (if recursivep +;;; 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*))) @@ -478,9 +542,22 @@ variables to allow for nested and thread safe reading." ;; Repeat if macro returned nothing. (when result (return (unless *read-suppress* (car result))))))))) - (with-reader () - (let ((*sharp-equal-alist* nil)) - (read-preserving-whitespace stream eof-error-p eof-value t))))) + (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) + (recursive-p nil)) + #!+sb-doc + "Read from STREAM and return the value read, preserving any whitespace + that followed the object." + (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. ;;; @@ -495,18 +572,17 @@ variables to allow for nested and thread safe reading." (defun read (&optional (stream *standard-input*) (eof-error-p t) - (eof-value ()) - (recursivep ())) + (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))) + (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) + (unless (or (eql result eof-value) recursive-p) (let ((next-char (read-char stream nil nil))) (unless (or (null next-char) (whitespace[2]p next-char)) @@ -520,12 +596,20 @@ variables to allow for nested and thread safe reading." #!+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." - (with-reader (recursive-p) - (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))))) + (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 ;;;; @@ -542,7 +626,9 @@ variables to allow for nested and thread safe reading." ((character-decoding-error #'(lambda (decoding-error) (declare (ignorable decoding-error)) - (style-warn "Character decoding error in a ;-comment at position ~A reading source file ~A, resyncing." (file-position stream) stream) + (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) @@ -568,7 +654,7 @@ variables to allow for nested and thread safe reading." (cond ((token-delimiterp nextchar) (cond ((eq listtail thelist) (unless *read-suppress* - (%reader-error + (simple-reader-error stream "Nothing appears before . in list."))) ((whitespace[2]p nextchar) @@ -593,7 +679,7 @@ variables to allow for nested and thread safe reading." ((char= char #\) ) (if *read-suppress* (return-from read-after-dot nil) - (%reader-error stream "Nothing appears after . in list."))) + (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))) @@ -605,7 +691,8 @@ variables to allow for nested and thread safe reading." ;; Try reading virtual whitespace. (if (and (read-maybe-nothing stream lastchar) (not *read-suppress*)) - (%reader-error stream "More than one object follows . in list."))))) + (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. @@ -633,7 +720,7 @@ variables to allow for nested and thread safe reading." (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: @@ -705,7 +792,7 @@ variables to allow for nested and thread safe reading." ((< att +char-attr-constituent+) att) (t (setf att (get-constituent-trait ,char)) (if (= att +char-attr-invalid+) - (%reader-error stream "invalid constituent") + (simple-reader-error stream "invalid constituent") att))))) ;;; Return the character class for CHAR, which might be part of a @@ -723,7 +810,7 @@ variables to allow for nested and thread safe reading." ((digit-char-p ,char *read-base*) +char-attr-constituent-digit+) ((= att +char-attr-constituent-digit+) +char-attr-constituent+) ((= att +char-attr-invalid+) - (%reader-error stream "invalid constituent")) + (simple-reader-error stream "invalid constituent")) (t att)))))) ;;; Return the character class for a char which might be part of a @@ -754,7 +841,7 @@ variables to allow for nested and thread safe reading." +char-attr-constituent-digit+) +char-attr-constituent-decimal-digit+)) ((= att +char-attr-invalid+) - (%reader-error stream "invalid constituent")) + (simple-reader-error stream "invalid constituent")) (t att)))))) ;;;; token fetching @@ -817,9 +904,12 @@ variables to allow for nested and thread safe reading." (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 @@ -853,7 +943,8 @@ variables to allow for nested and thread safe reading." (#.+char-attr-single-escape+ (go SINGLE-ESCAPE)) (#.+char-attr-package-delimiter+ (go COLON)) (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) - (#.+char-attr-invalid+ (%reader-error stream "invalid constituent")) + (#.+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" @@ -984,11 +1075,12 @@ variables to allow for nested and thread safe reading." FRONTDOT ; saw "dot" (ouch-read-buffer char) (setq char (read-char stream nil nil)) - (unless char (%reader-error stream "dot context error")) + (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+ (%reader-error stream "dot context error")) + (#.+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)) @@ -1057,12 +1149,12 @@ variables to allow for nested and thread safe reading." DOTS ; saw "dot {dot}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) - (unless char (%reader-error stream "too many dots")) + (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) - (%reader-error stream "too many dots")) + (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)) @@ -1134,8 +1226,9 @@ variables to allow for nested and thread safe reading." 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*) @@ -1155,9 +1248,9 @@ variables to allow for nested and thread safe reading." (case (char-class char attribute-array attribute-hash-table) (#.+char-attr-delimiter+ (unread-char char stream) - (%reader-error stream - "illegal terminating character after a colon: ~S" - char)) + (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)) @@ -1170,26 +1263,29 @@ variables to allow for nested and thread safe reading." (case (char-class char attribute-array attribute-hash-table) (#.+char-attr-delimiter+ (unread-char char stream) - (%reader-error stream - "illegal terminating character after a colon: ~S" - char)) + (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+ - (%reader-error stream - "too many colons after ~S name" - package-designator)) + (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")) - + (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) @@ -1197,7 +1293,9 @@ variables to allow for nested and thread safe reading." (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 + (error 'simple-reader-package-error + :package found + :stream stream :format-arguments (list name (package-name found)) :format-control (if test @@ -1311,6 +1409,24 @@ variables to allow for nested and thread safe reading." (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. @@ -1371,6 +1487,7 @@ variables to allow for nested and thread safe reading." (#\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 @@ -1383,7 +1500,8 @@ variables to allow for nested and thread safe reading." (type-error (c) (error 'reader-impossible-number-error :error c :stream stream - :format-control "failed to build float")))) + :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 @@ -1417,63 +1535,15 @@ variables to allow for nested and thread safe reading." :format-control "failed to build ratio"))))) (if negative-number (- num) num)))) -;;;; cruft for dispatch macros - -(defun make-char-dispatch-table () - (make-hash-table)) +;;;; 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 (gethash sub-char (cdr dpair)) (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 - (values (gethash sub-char (cdr dpair))) - (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. @@ -1498,26 +1568,82 @@ variables to allow for nested and thread safe reading." (funcall (the function (gethash sub-char (cdr dpair) #'dispatch-char-error)) stream sub-char (if numargp numarg nil)) - (%reader-error stream "no dispatch table for dispatch char"))))) + (simple-reader-error stream + "no dispatch table for dispatch char"))))) ;;;; READ-FROM-STRING -(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)) +(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 (%check-vector-sequence-bounds string start end))) + (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) + (%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)) + (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 @@ -1533,7 +1659,8 @@ variables to allow for nested and thread safe reading." :format-arguments (list string)))) (with-array-data ((string string :offset-var offset) (start start) - (end (%check-vector-sequence-bounds string start end))) + (end end) + :check-fill-pointer t) (let ((index (do ((i start (1+ i))) ((= i end) (if junk-allowed