X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Freader.lisp;h=2372ef8750fd2165af1f6dee3cd7f5fe36d6b739;hb=0e5e8dc759b478bf9ef55d45d80604c24faea2ae;hp=bc7c7b11911c41c67a56812c4215d11c084533a6;hpb=722703e7cbd3a4b279a4c1baab5d95df2c23cce9;p=sbcl.git diff --git a/src/code/reader.lisp b/src/code/reader.lisp index bc7c7b1..2372ef8 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* @@ -186,42 +198,51 @@ (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." - (let ((rt (or rt *standard-readtable*))) - (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 "Return 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)))) + 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 @@ -249,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)) @@ -277,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 @@ -387,7 +412,7 @@ (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. @@ -401,7 +426,9 @@ ;;; 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*) @@ -773,13 +800,13 @@ RIGHTDIGIT ; saw "[sign] {digit}* dot {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) - (unless char (return (make-float))) + (unless char (return (make-float stream))) (case (char-class char attribute-table) (#.+char-attr-constituent-digit+ (go RIGHTDIGIT)) (#.+char-attr-constituent-expt+ (go EXPONENT)) (#.+char-attr-delimiter+ (unread-char char stream) - (return (make-float))) + (return (make-float stream))) (#.+char-attr-escape+ (go ESCAPE)) (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) (#.+char-attr-package-delimiter+ (go COLON)) @@ -832,12 +859,12 @@ EXPTDIGIT ; got to EXPONENT, saw "[sign] {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) - (unless char (return (make-float))) + (unless char (return (make-float stream))) (case (char-class char attribute-table) (#.+char-attr-constituent-digit+ (go EXPTDIGIT)) (#.+char-attr-delimiter+ (unread-char char stream) - (return (make-float))) + (return (make-float stream))) (#.+char-attr-escape+ (go ESCAPE)) (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) (#.+char-attr-package-delimiter+ (go COLON)) @@ -856,12 +883,12 @@ RATIODIGIT ; saw "[sign] {digit}+ slash {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) - (unless char (return (make-ratio))) + (unless char (return (make-ratio stream))) (case (char-class2 char attribute-table) (#.+char-attr-constituent-digit+ (go RATIODIGIT)) (#.+char-attr-delimiter+ (unread-char char stream) - (return (make-ratio))) + (return (make-ratio stream))) (#.+char-attr-escape+ (go ESCAPE)) (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) (#.+char-attr-package-delimiter+ (go COLON)) @@ -1120,7 +1147,7 @@ (the index (* num base)))))))) (setq number (+ num (* number base-power))))))) -(defun make-float () +(defun make-float (stream) ;; Assume that the contents of *read-buffer* are a legal float, with nothing ;; else after it. (read-unwind-read-buffer) @@ -1154,7 +1181,8 @@ (cond ((eofp char) ;; If not, we've read the whole number. (let ((num (make-float-aux number divisor - *read-default-float-format*))) + *read-default-float-format* + stream))) (return-from make-float (if negative-fraction (- num) num)))) ((exponent-letterp char) (setq float-char char) @@ -1180,35 +1208,34 @@ (#\D 'double-float) (#\L 'long-float))) num) - ;; toy@rtp.ericsson.se: We need to watch out if the + ;; Raymond Toy writes: We need to watch out if the ;; exponent is too small or too large. We add enough to ;; EXPONENT to make it within range and scale NUMBER ;; appropriately. This should avoid any unnecessary ;; underflow or overflow problems. (multiple-value-bind (min-expo max-expo) - ;; FIXME: These #. forms are broken w.r.t. - ;; cross-compilation portability. Maybe expressions - ;; like - ;; (LOG SB!XC:MOST-POSITIVE-SHORT-FLOAT 10s0) - ;; could be used instead? Or perhaps some sort of - ;; load-time-form magic? + ;; FIXME: These forms are broken w.r.t. + ;; cross-compilation portability, as the + ;; cross-compiler will call the host's LOG function + ;; while attempting to constant-fold. Maybe some sort + ;; of load-time-form magic could be used instead? (case float-format (short-float (values - #.(log least-positive-normalized-short-float 10s0) - #.(log most-positive-short-float 10s0))) + (log sb!xc:least-positive-normalized-short-float 10s0) + (log sb!xc:most-positive-short-float 10s0))) (single-float (values - #.(log least-positive-normalized-single-float 10f0) - #.(log most-positive-single-float 10f0))) + (log sb!xc:least-positive-normalized-single-float 10f0) + (log sb!xc:most-positive-single-float 10f0))) (double-float (values - #.(log least-positive-normalized-double-float 10d0) - #.(log most-positive-double-float 10d0))) + (log sb!xc:least-positive-normalized-double-float 10d0) + (log sb!xc:most-positive-double-float 10d0))) (long-float (values - #.(log least-positive-normalized-long-float 10L0) - #.(log most-positive-long-float 10L0)))) + (log sb!xc:least-positive-normalized-long-float 10L0) + (log sb!xc:most-positive-long-float 10L0)))) (let ((correction (cond ((<= exponent min-expo) (ceiling (- min-expo exponent))) ((>= exponent max-expo) @@ -1217,7 +1244,7 @@ 0)))) (incf exponent correction) (setf number (/ number (expt 10 correction))) - (setq num (make-float-aux number divisor float-format)) + (setq num (make-float-aux number divisor float-format stream)) (setq num (* num (expt 10 exponent))) (return-from make-float (if negative-fraction (- num) @@ -1225,10 +1252,15 @@ ;; should never happen (t (bug "bad fallthrough in floating point reader"))))) -(defun make-float-aux (number divisor float-format) - (coerce (/ number divisor) float-format)) +(defun make-float-aux (number divisor float-format stream) + (handler-case + (coerce (/ number divisor) float-format) + (type-error (c) + (error 'reader-impossible-number-error + :error c :stream stream + :format-control "failed to build float")))) -(defun make-ratio () +(defun make-ratio (stream) ;; Assume *READ-BUFFER* contains a legal ratio. Build the number from ;; the string. ;; @@ -1252,7 +1284,12 @@ (dig ())) ((or (eofp ch) (not (setq dig (digit-char-p ch *read-base*))))) (setq denominator (+ (* denominator *read-base*) dig))) - (let ((num (/ numerator denominator))) + (let ((num (handler-case + (/ numerator denominator) + (arithmetic-error (c) + (error 'reader-impossible-number-error + :error c :stream stream + :format-control "failed to build ratio"))))) (if negative-number (- num) num)))) ;;;; cruft for dispatch macros @@ -1388,51 +1425,55 @@ (default to the beginning and end of the string) It skips over whitespace characters and then tries to parse an integer. The radix parameter must be between 2 and 36." - (with-array-data ((string string) - (start start) - (end (or end (length string)))) - (let ((index (do ((i start (1+ i))) - ((= i end) - (if junk-allowed - (return-from parse-integer (values nil end)) - (error "no non-whitespace characters in number"))) - (declare (fixnum i)) - (unless (whitespacep (char string i)) (return i)))) - (minusp nil) - (found-digit nil) - (result 0)) - (declare (fixnum index)) - (let ((char (char string index))) - (cond ((char= char #\-) - (setq minusp t) - (incf index)) - ((char= char #\+) - (incf index)))) - (loop - (when (= index end) (return nil)) - (let* ((char (char string index)) - (weight (digit-char-p char radix))) - (cond (weight - (setq result (+ weight (* result radix)) - found-digit t)) - (junk-allowed (return nil)) - ((whitespacep char) - (do ((jndex (1+ index) (1+ jndex))) - ((= jndex end)) - (declare (fixnum jndex)) - (unless (whitespacep (char string jndex)) - (error "junk in string ~S" string))) - (return nil)) - (t - (error "junk in string ~S" string)))) - (incf index)) - (values - (if found-digit - (if minusp (- result) result) - (if junk-allowed - nil - (error "no digits in string ~S" string))) - index)))) + (macrolet ((parse-error (format-control) + `(error 'simple-parse-error + :format-control ,format-control + :format-arguments (list string)))) + (with-array-data ((string string) + (start start) + (end (or end (length string)))) + (let ((index (do ((i start (1+ i))) + ((= i end) + (if junk-allowed + (return-from parse-integer (values nil end)) + (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))))) ;;;; reader initialization code