(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*
;;;; 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)))
- (setf (readtable-case to-readtable)
- (readtable-case 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*)
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)))
(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
- "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))))
+ "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))))
\f
;;;; 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
(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))
(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)))))
\f
;;;; implementation of the read buffer
(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.
;;; 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*)
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))
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))
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))
(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)
(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)
((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)
(#\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)
0))))
(incf exponent correction)
(setf number (/ number (expt 10 correction)))
- (setq num (make-float-aux number divisor float-format))
+ (setq num (make-float-aux number divisor float-format stream))
(setq num (* num (expt 10 exponent)))
(return-from make-float (if negative-fraction
(- num)
num))))))
- ;; should never happen:
- (t (error "internal error in floating point reader")))))
-
-(defun make-float-aux (number divisor float-format)
- (coerce (/ number divisor) float-format))
-
-(defun make-ratio ()
+ ;; should never happen
+ (t (bug "bad fallthrough in floating point reader")))))
+
+(defun make-float-aux (number divisor float-format stream)
+ (handler-case
+ (coerce (/ number divisor) float-format)
+ (type-error (c)
+ (error 'reader-impossible-number-error
+ :error c :stream stream
+ :format-control "failed to build float"))))
+
+(defun make-ratio (stream)
;; Assume *READ-BUFFER* contains a legal ratio. Build the number from
;; the string.
;;
(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))))
\f
;;;; cruft for dispatch macros
(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
(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."
- (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.
(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)))))
\f
;;;; reader initialization code