X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Freader.lisp;h=c97cae9d4e952094b3b1784ad5111da7d8d03860;hb=8731c1a7c1a585d190151fa881050fb5e14c0616;hp=32661aa9f7920902b66b394788567cc888f6532f;hpb=d147d512602d761a2dcdfded506dd1a8f9a140dc;p=sbcl.git diff --git a/src/code/reader.lisp b/src/code/reader.lisp index 32661aa..c97cae9 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -69,16 +69,28 @@ (char-code char)) newvalue)) -;;; FIXME: could be SB!XC:DEFMACRO inside EVAL-WHEN (COMPILE EVAL) -(defmacro get-cmt-entry (char rt) - `(the function - (elt (the simple-vector (character-macro-table ,rt)) - (char-code ,char)))) - -(defun set-cmt-entry (char newvalue &optional (rt *readtable*)) - (setf (elt (the simple-vector (character-macro-table rt)) - (char-code char)) - (coerce newvalue 'function))) +;;; the value actually stored in the character macro table. As per +;;; ANSI #'GET-MACRO-CHARACTER and #'SET-MACRO-CHARACTER, this can +;;; be either a function or NIL. +(eval-when (:compile-toplevel :execute) + (sb!xc:defmacro get-raw-cmt-entry (char readtable) + `(svref (character-macro-table ,readtable) + (char-code ,char)))) + +;;; the value represented by whatever is stored in the character macro +;;; table. As per ANSI #'GET-MACRO-CHARACTER and #'SET-MACRO-CHARACTER, +;;; a function value represents itself, and a NIL value represents the +;;; default behavior. +(defun get-coerced-cmt-entry (char readtable) + (the function + (or (get-raw-cmt-entry char readtable) + #'read-token))) + +(defun set-cmt-entry (char new-value-designator &optional (rt *readtable*)) + (setf (svref (character-macro-table rt) + (char-code char)) + (and new-value-designator + (%coerce-callable-to-fun new-value-designator)))) (defun undefined-macro-char (stream char) (unless *read-suppress* @@ -154,17 +166,20 @@ ;;;; readtable operations (defun copy-readtable (&optional (from-readtable *readtable*) - (to-readtable (make-readtable))) - (let ((really-from-readtable (or from-readtable *standard-readtable*))) - (replace (character-attribute-table to-readtable) + to-readtable) + (let ((really-from-readtable (or from-readtable *standard-readtable*)) + (really-to-readtable (or to-readtable (make-readtable)))) + (replace (character-attribute-table really-to-readtable) (character-attribute-table really-from-readtable)) - (replace (character-macro-table to-readtable) + (replace (character-macro-table really-to-readtable) (character-macro-table really-from-readtable)) - (setf (dispatch-tables to-readtable) - (mapcar #'(lambda (pair) (cons (car pair) - (copy-seq (cdr pair)))) + (setf (dispatch-tables really-to-readtable) + (mapcar (lambda (pair) (cons (car pair) + (copy-seq (cdr pair)))) (dispatch-tables really-from-readtable))) - to-readtable)) + (setf (readtable-case really-to-readtable) + (readtable-case really-from-readtable)) + really-to-readtable)) (defun set-syntax-from-char (to-char from-char &optional (to-readtable *readtable*) @@ -175,7 +190,7 @@ FROM-TABLE defaults to the standard Lisp readtable when NIL." (let ((really-from-readtable (or from-readtable *standard-readtable*))) ;; Copy FROM-CHAR entries to TO-CHAR entries, but make sure that if - ;; from char is a constituent you don't copy non-movable secondary + ;; 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))) @@ -183,47 +198,57 @@ (setq att (get-secondary-attribute to-char))) (set-cat-entry to-char att to-readtable) (set-cmt-entry to-char - (get-cmt-entry from-char really-from-readtable) + (get-raw-cmt-entry from-char really-from-readtable) to-readtable))) t) (defun set-macro-character (char function &optional - (non-terminatingp nil) (rt *readtable*)) + (non-terminatingp nil) + (readtable *readtable*)) #!+sb-doc - "Causes char to be a macro character which invokes function when - seen by the reader. The non-terminatingp flag can be used to - make the macro character non-terminating. The optional readtable - argument defaults to the current readtable. Set-macro-character - returns T." - (if non-terminatingp - (set-cat-entry char (get-secondary-attribute char) rt) - (set-cat-entry char +char-attr-terminating-macro+ rt)) - (set-cmt-entry char function rt) - T) - -(defun get-macro-character (char &optional (rt *readtable*)) + "Causes CHAR to be a macro character which invokes FUNCTION when seen + by the reader. The NON-TERMINATINGP flag can be used to make the macro + character non-terminating, i.e. embeddable in a symbol name." + (let ((designated-readtable (or readtable *standard-readtable*))) + (set-cat-entry char + (if non-terminatingp + (get-secondary-attribute char) + +char-attr-terminating-macro+) + designated-readtable) + (set-cmt-entry char function designated-readtable) + t)) ; (ANSI-specified return value) + +(defun get-macro-character (char &optional (readtable *readtable*)) #!+sb-doc - "Returns the function associated with the specified char which is a macro - character. The optional readtable argument defaults to the current - readtable." - (let ((rt (or rt *standard-readtable*))) - ;; Check macro syntax, return associated function if it's there. - ;; Returns a value for all constituents. - (cond ((constituentp char) - (values (get-cmt-entry char rt) t)) - ((terminating-macrop char) - (values (get-cmt-entry char rt) nil)) - (t nil)))) + "Return the function associated with the specified CHAR which is a macro + character, or NIL if there is no such function. As a second value, return + T if CHAR is a macro character which is non-terminating, i.e. which can + be embedded in a symbol name." + (let* ((designated-readtable (or readtable *standard-readtable*)) + ;; the first return value: a FUNCTION if CHAR is a macro + ;; character, or NIL otherwise + (fun-value (get-raw-cmt-entry char designated-readtable))) + (values fun-value + ;; NON-TERMINATING-P return value: + (if fun-value + (or (constituentp char) + (not (terminating-macrop char))) + ;; ANSI's definition of GET-MACRO-CHARACTER says this + ;; value is NIL when CHAR is not a macro character. + ;; I.e. this value means not just "non-terminating + ;; character?" but "non-terminating macro character?". + nil)))) ;;;; definitions to support internal programming conventions -(defmacro eofp (char) `(eq ,char *eof-object*)) +(defmacro eofp (char) + `(eq ,char *eof-object*)) (defun flush-whitespace (stream) ;; This flushes whitespace chars, returning the last char it read (a ;; non-white one). It always gets an error on end-of-file. (let ((stream (in-synonym-of stream))) - (if (lisp-stream-p stream) + (if (ansi-stream-p stream) (prepare-for-fast-read-char stream (do ((attribute-table (character-attribute-table *readtable*)) (char (fast-read-char t) (fast-read-char t))) @@ -245,27 +270,31 @@ (defun !cold-init-standard-readtable () (setq *standard-readtable* (make-readtable)) - ;; All characters default to "constituent" in MAKE-READTABLE. - ;; *** un-constituent-ize some of these *** + ;; All characters get boring defaults in MAKE-READTABLE. Now we + ;; override the boring defaults on characters which need more + ;; interesting behavior. (let ((*readtable* *standard-readtable*)) - (set-cat-entry (code-char tab-char-code) +char-attr-whitespace+) - (set-cat-entry #\linefeed +char-attr-whitespace+) - (set-cat-entry #\space +char-attr-whitespace+) - (set-cat-entry (code-char form-feed-char-code) +char-attr-whitespace+) - (set-cat-entry (code-char return-char-code) +char-attr-whitespace+) + + (flet ((whitespaceify (char) + (set-cat-entry char +char-attr-whitespace+))) + (whitespaceify (code-char tab-char-code)) + (whitespaceify #\linefeed) + (whitespaceify #\space) + (whitespaceify (code-char form-feed-char-code)) + (whitespaceify (code-char return-char-code))) + (set-cat-entry #\\ +char-attr-escape+) (set-cmt-entry #\\ #'read-token) - (set-cat-entry (code-char rubout-char-code) +char-attr-whitespace+) - (set-cmt-entry #\: #'read-token) - (set-cmt-entry #\| #'read-token) - ;; macro definitions + + ;; Easy macro-character definitions are in this source file. (set-macro-character #\" #'read-string) - ;; * # macro (set-macro-character #\' #'read-quote) (set-macro-character #\( #'read-list) (set-macro-character #\) #'read-right-paren) (set-macro-character #\; #'read-comment) - ;; * backquote + ;; (The hairier macro-character definitions, for #\# and #\`, are + ;; defined elsewhere, in their own source files.) + ;; all constituents (do ((ichar 0 (1+ ichar)) (char)) @@ -273,7 +302,7 @@ (setq char (code-char ichar)) (when (constituentp char *standard-readtable*) (set-cat-entry char (get-secondary-attribute char)) - (set-cmt-entry char #'read-token))))) + (set-cmt-entry char nil))))) ;;;; implementation of the read buffer @@ -374,56 +403,61 @@ (eof-value nil) (recursivep nil)) #!+sb-doc - "Reads from stream and returns the object read, preserving the whitespace + "Read from STREAM and return the value read, preserving any whitespace that followed the object." - (cond - (recursivep + (if recursivep ;; a loop for repeating when a macro returns nothing (loop (let ((char (read-char stream eof-error-p *eof-object*))) (cond ((eofp char) (return eof-value)) ((whitespacep char)) (t - (let* ((macrofun (get-cmt-entry char *readtable*)) + (let* ((macrofun (get-coerced-cmt-entry char *readtable*)) (result (multiple-value-list (funcall macrofun stream char)))) ;; Repeat if macro returned nothing. - (if result (return (car result))))))))) - (t + (if result (return (car result)))))))) (let ((*sharp-equal-alist* nil)) - (read-preserving-whitespace stream eof-error-p eof-value t))))) + (read-preserving-whitespace stream eof-error-p eof-value t)))) ;;; Return NIL or a list with one thing, depending. ;;; ;;; for functions that want comments to return so that they can look -;;; past them. Assumes char is not whitespace. +;;; past them. We assume CHAR is not whitespace. (defun read-maybe-nothing (stream char) (let ((retval (multiple-value-list - (funcall (get-cmt-entry char *readtable*) stream char)))) + (funcall (get-coerced-cmt-entry char *readtable*) + stream + char)))) (if retval (rplacd retval nil)))) -(defun read (&optional (stream *standard-input*) (eof-error-p t) - (eof-value ()) (recursivep ())) +(defun read (&optional (stream *standard-input*) + (eof-error-p t) + (eof-value ()) + (recursivep ())) #!+sb-doc - "Reads in the next object in the stream, which defaults to - *standard-input*. For details see the I/O chapter of - the manual." - (prog1 - (read-preserving-whitespace stream eof-error-p eof-value recursivep) - (let ((whitechar (read-char stream nil *eof-object*))) - (if (and (not (eofp whitechar)) - (or (not (whitespacep whitechar)) - recursivep)) - (unread-char whitechar stream))))) + "Read the next Lisp value from STREAM, and return it." + (let ((result (read-preserving-whitespace stream + eof-error-p + eof-value + recursivep))) + ;; (This function generally discards trailing whitespace. If you + ;; don't want to discard trailing whitespace, call + ;; CL:READ-PRESERVING-WHITESPACE instead.) + (unless (or (eql result eof-value) recursivep) + (let ((next-char (read-char stream nil nil))) + (unless (or (null next-char) + (whitespacep next-char)) + (unread-char next-char stream)))) + result)) ;;; (This is a COMMON-LISP exported symbol.) (defun read-delimited-list (endchar &optional (input-stream *standard-input*) recursive-p) #!+sb-doc - "Reads objects from input-stream until the next character after an - object's representation is endchar. A list of those objects read - is returned." + "Read Lisp values from INPUT-STREAM until the next character after a + value's representation is ENDCHAR, and return the objects as a list." (declare (ignore recursive-p)) (do ((char (flush-whitespace input-stream) (flush-whitespace input-stream)) @@ -433,8 +467,8 @@ ;;;; basic readmacro definitions ;;;; -;;;; Large, hairy subsets of readmacro definitions (backquotes and sharp -;;;; macros) are not here, but in their own source files. +;;;; Some large, hairy subsets of readmacro definitions (backquotes +;;;; and sharp macros) are not here, but in their own source files. (defun read-quote (stream ignore) (declare (ignore ignore)) @@ -443,7 +477,7 @@ (defun read-comment (stream ignore) (declare (ignore ignore)) (let ((stream (in-synonym-of stream))) - (if (lisp-stream-p stream) + (if (ansi-stream-p stream) (prepare-for-fast-read-char stream (do ((char (fast-read-char nil nil) (fast-read-char nil nil))) @@ -506,7 +540,7 @@ ;; For a very long string, this could end up bloating the read buffer. (reset-read-buffer) (let ((stream (in-synonym-of stream))) - (if (lisp-stream-p stream) + (if (ansi-stream-p stream) (prepare-for-fast-read-char stream (do ((char (fast-read-char t) (fast-read-char t))) ((char= char closech) @@ -632,11 +666,11 @@ (defvar *read-suppress* nil #!+sb-doc - "Suppresses most interpreting of the reader when T") + "Suppress most interpreting in the reader when T.") (defvar *read-base* 10 #!+sb-doc - "The radix that Lisp reads numbers in.") + "the radix that Lisp reads numbers in") (declaim (type (integer 2 36) *read-base*)) ;;; Modify the read buffer according to READTABLE-CASE, ignoring @@ -874,7 +908,7 @@ (t (go SYMBOL))) SYMBOL ; not a dot, dots, or number (let ((stream (in-synonym-of stream))) - (if (lisp-stream-p stream) + (if (ansi-stream-p stream) (prepare-for-fast-read-char stream (prog () SYMBOL-LOOP @@ -1165,7 +1199,7 @@ ((not dig) (setq exponent (if negative-exponent (- exponent) exponent))) (setq exponent (+ (* exponent 10) dig))) - ;; Generate and return the float, depending on float-char: + ;; Generate and return the float, depending on FLOAT-CHAR: (let* ((float-format (case (char-upcase float-char) (#\E *read-default-float-format*) (#\S 'short-float) @@ -1215,8 +1249,8 @@ (return-from make-float (if negative-fraction (- num) num)))))) - ;; should never happen: - (t (error "internal error in floating point reader"))))) + ;; should never happen + (t (bug "bad fallthrough in floating point reader"))))) (defun make-float-aux (number divisor float-format) (coerce (/ number divisor) float-format)) @@ -1273,7 +1307,8 @@ (error "The dispatch character ~S already exists." char)) (t (setf (dispatch-tables rt) - (push (cons char (make-char-dispatch-table)) dalist)))))) + (push (cons char (make-char-dispatch-table)) dalist))))) + t) (defun set-dispatch-macro-character (disp-char sub-char function &optional (rt *readtable*)) @@ -1285,6 +1320,7 @@ (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 @@ -1296,17 +1332,22 @@ (defun get-dispatch-macro-character (disp-char sub-char &optional (rt *readtable*)) #!+sb-doc - "Returns the macro character function for sub-char under disp-char - or nil if there is no associated function." - (unless (digit-char-p sub-char) - (let* ((sub-char (char-upcase sub-char)) - (rt (or rt *standard-readtable*)) - (dpair (find disp-char (dispatch-tables rt) - :test #'char= :key #'car))) - (if dpair - (elt (the simple-vector (cdr dpair)) - (char-code sub-char)) - (error "~S is not a dispatch char." disp-char))))) + "Return the macro character function for SUB-CHAR under DISP-CHAR + or NIL if there is no associated function." + (let* ((sub-char (char-upcase sub-char)) + (rt (or rt *standard-readtable*)) + (dpair (find disp-char (dispatch-tables rt) + :test #'char= :key #'car))) + (if dpair + (let ((dispatch-fun (elt (the simple-vector (cdr dpair)) + (char-code sub-char)))) + ;; Digits are also initialized in a dispatch table to + ;; #'dispatch-char-error; READ-DISPATCH-CHAR handles them + ;; separately. - CSR, 2002-04-12 + (if (eq dispatch-fun #'dispatch-char-error) + nil + dispatch-fun)) + (error "~S is not a dispatch char." disp-char)))) (defun read-dispatch-char (stream char) ;; Read some digits.