X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Freader.lisp;h=77a9555f94bf7e39a44afd0ae372730a39d4709d;hb=416152f084604094445a758ff399871132dff2bd;hp=b8c6de29073edc153804f4688a63044f3007ecc8;hpb=68c539ab90bb39f342229e68bf9286f63824597a;p=sbcl.git diff --git a/src/code/reader.lisp b/src/code/reader.lisp index b8c6de2..77a9555 100644 --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -55,26 +55,6 @@ :format-control control :format-arguments args)) -;;;; constants for character attributes. These are all as in the manual. - -;;; FIXME: It's disturbing to bind nice names like ESCAPE and DELIMITER -;;; as constants throughout the entire SB-IMPL package. Perhaps these -;;; could be given some standard prefix, so instead we have constants -;;; CHATTR-ESCAPE and CHATTR-DELIMITER and so forth. -(defconstant whitespace 0) -(defconstant terminating-macro 1) -(defconstant escape 2) -(defconstant constituent 3) -(defconstant constituent-dot 4) -(defconstant constituent-expt 5) -(defconstant constituent-slash 6) -(defconstant constituent-digit 7) -(defconstant constituent-sign 8) -;; the "9" entry intentionally left blank for some reason -- WHN 19990806 -(defconstant multiple-escape 10) -(defconstant package-delimiter 11) -(defconstant delimiter 12) ; (a fake for use in read-unqualified-token) - ;;;; macros and functions for character tables ;;; FIXME: could be SB!XC:DEFMACRO inside EVAL-WHEN (COMPILE EVAL) @@ -113,28 +93,28 @@ #!-sb-fluid (declaim (inline whitespacep)) (defun whitespacep (char &optional (rt *readtable*)) - (test-attribute char whitespace rt)) + (test-attribute char +char-attr-whitespace+ rt)) (defmacro constituentp (char &optional (rt '*readtable*)) - `(>= (get-cat-entry ,char ,rt) constituent)) + `(>= (get-cat-entry ,char ,rt) +char-attr-constituent+)) (defmacro terminating-macrop (char &optional (rt '*readtable*)) - `(test-attribute ,char terminating-macro ,rt)) + `(test-attribute ,char +char-attr-terminating-macro+ ,rt)) (defmacro escapep (char &optional (rt '*readtable*)) - `(test-attribute ,char escape ,rt)) + `(test-attribute ,char +char-attr-escape+ ,rt)) (defmacro multiple-escape-p (char &optional (rt '*readtable*)) - `(test-attribute ,char multiple-escape ,rt)) + `(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) terminating-macro)) + `(<= (get-cat-entry ,char ,rt) +char-attr-terminating-macro+)) ;;;; secondary attribute table -;;; There are a number of "secondary" attributes which are constant properties -;;; of characters (as long as they are constituents). +;;; 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*)) @@ -146,26 +126,26 @@ (defun !cold-init-secondary-attribute-table () (setq *secondary-attribute-table* (make-array char-code-limit :element-type '(unsigned-byte 8) - :initial-element constituent)) - (!set-secondary-attribute #\: package-delimiter) - (!set-secondary-attribute #\| multiple-escape) ; |) [for EMACS] - (!set-secondary-attribute #\. constituent-dot) - (!set-secondary-attribute #\+ constituent-sign) - (!set-secondary-attribute #\- constituent-sign) - (!set-secondary-attribute #\/ constituent-slash) + :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+) (do ((i (char-code #\0) (1+ i))) ((> i (char-code #\9))) - (!set-secondary-attribute (code-char i) constituent-digit)) - (!set-secondary-attribute #\E constituent-expt) - (!set-secondary-attribute #\F constituent-expt) - (!set-secondary-attribute #\D constituent-expt) - (!set-secondary-attribute #\S constituent-expt) - (!set-secondary-attribute #\L constituent-expt) - (!set-secondary-attribute #\e constituent-expt) - (!set-secondary-attribute #\f constituent-expt) - (!set-secondary-attribute #\d constituent-expt) - (!set-secondary-attribute #\s constituent-expt) - (!set-secondary-attribute #\l constituent-expt)) + (!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* @@ -184,6 +164,8 @@ (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)) (defun set-syntax-from-char (to-char from-char &optional @@ -194,7 +176,7 @@ optional readtable (defaults to the current readtable). The 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 + ;; 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. @@ -217,7 +199,7 @@ returns T." (if non-terminatingp (set-cat-entry char (get-secondary-attribute char) rt) - (set-cat-entry char terminating-macro rt)) + (set-cat-entry char +char-attr-terminating-macro+ rt)) (set-cmt-entry char function rt) T) @@ -248,7 +230,7 @@ (do ((attribute-table (character-attribute-table *readtable*)) (char (fast-read-char t) (fast-read-char t))) ((/= (the fixnum (aref attribute-table (char-code char))) - whitespace) + +char-attr-whitespace+) (done-with-fast-read-char) char))) ;; fundamental-stream @@ -256,7 +238,7 @@ (char (stream-read-char stream) (stream-read-char stream))) ((or (eq char :eof) (/= (the fixnum (aref attribute-table (char-code char))) - whitespace)) + +char-attr-whitespace+)) (if (eq char :eof) (error 'end-of-file :stream stream) char)))))) @@ -268,14 +250,14 @@ ;; All characters default to "constituent" in MAKE-READTABLE. ;; *** un-constituent-ize some of these *** (let ((*readtable* *standard-readtable*)) - (set-cat-entry (code-char tab-char-code) whitespace) - (set-cat-entry #\linefeed whitespace) - (set-cat-entry #\space whitespace) - (set-cat-entry (code-char form-feed-char-code) whitespace) - (set-cat-entry (code-char return-char-code) whitespace) - (set-cat-entry #\\ escape) + (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+) + (set-cat-entry #\\ +char-attr-escape+) (set-cmt-entry #\\ #'read-token) - (set-cat-entry (code-char rubout-char-code) whitespace) + (set-cat-entry (code-char rubout-char-code) +char-attr-whitespace+) (set-cmt-entry #\: #'read-token) (set-cmt-entry #\| #'read-token) ;; macro definitions @@ -386,17 +368,17 @@ (declaim (special *standard-input*)) -;;; READ-PRESERVING-WHITESPACE behaves just like READ, only it makes sure -;;; to leave terminating whitespace in the stream. +;;; 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 - "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*))) @@ -407,40 +389,46 @@ (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. We assume CHAR is not whitespace. (defun read-maybe-nothing (stream char) - ;;returns nil or a list with one thing, depending. - ;;for functions that want comments to return so they can look - ;;past them. Assumes char is not whitespace. (let ((retval (multiple-value-list (funcall (get-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)) @@ -450,8 +438,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)) @@ -595,7 +583,7 @@ (t (when (and (constituentp char) (eql (get-secondary-attribute char) - package-delimiter) + +char-attr-package-delimiter+) (not colon)) (setq colon *ouch-ptr*)) (ouch-read-buffer char)))))) @@ -606,8 +594,8 @@ (defmacro char-class (char attable) `(let ((att (aref ,attable (char-code ,char)))) (declare (fixnum att)) - (if (<= att terminating-macro) - delimiter + (if (<= att +char-attr-terminating-macro+) + +char-attr-delimiter+ att))) ;;; Return the character class for CHAR, which might be part of a @@ -615,48 +603,50 @@ (defmacro char-class2 (char attable) `(let ((att (aref ,attable (char-code ,char)))) (declare (fixnum att)) - (if (<= att terminating-macro) - delimiter + (if (<= att +char-attr-terminating-macro+) + +char-attr-delimiter+ (if (digit-char-p ,char *read-base*) - constituent-digit - (if (= att constituent-digit) - constituent + +char-attr-constituent-digit+ + (if (= att +char-attr-constituent-digit+) + +char-attr-constituent+ 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.) +;;; 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)))) (declare (fixnum att)) (if possibly-rational (setq possibly-rational (or (digit-char-p ,char *read-base*) - (= att constituent-slash)))) + (= att +char-attr-constituent-slash+)))) (if possibly-float (setq possibly-float (or (digit-char-p ,char 10) - (= att constituent-dot)))) - (if (<= att terminating-macro) - delimiter + (= 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*) - constituent-digit - constituent) + +char-attr-constituent-digit+ + +char-attr-constituent+) att)))) ;;;; token fetching (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 escapes. -;;; ESCAPES is a list of the escaped indices, in reverse order. +;;; Modify the read buffer according to READTABLE-CASE, ignoring +;;; ESCAPES. ESCAPES is a list of the escaped indices, in reverse +;;; order. (defun casify-read-buffer (escapes) (let ((case (readtable-case *readtable*))) (cond @@ -676,7 +666,7 @@ (declare (fixnum esc)) (cond ((< esc i) t) (t - (assert (= esc i)) + (aver (= esc i)) (pop escapes) nil)))) (let ((ch (schar *read-buffer* i))) @@ -721,12 +711,12 @@ (reset-read-buffer) (prog ((char firstchar)) (case (char-class3 char attribute-table) - (#.constituent-sign (go SIGN)) - (#.constituent-digit (go LEFTDIGIT)) - (#.constituent-dot (go FRONTDOT)) - (#.escape (go ESCAPE)) - (#.package-delimiter (go COLON)) - (#.multiple-escape (go MULT-ESCAPE)) + (#.+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))) SIGN ; saw "sign" @@ -736,30 +726,31 @@ (setq possibly-rational t possibly-float t) (case (char-class3 char attribute-table) - (#.constituent-digit (go LEFTDIGIT)) - (#.constituent-dot (go SIGNDOT)) - (#.escape (go ESCAPE)) - (#.package-delimiter (go COLON)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) + (#.+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))) 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) - (#.constituent-digit (go LEFTDIGIT)) - (#.constituent-dot (if possibly-float - (go MIDDLEDOT) - (go SYMBOL))) - (#.constituent-expt (go EXPONENT)) - (#.constituent-slash (if possibly-rational - (go RATIO) - (go SYMBOL))) - (#.delimiter (unread-char char stream) (return (make-integer))) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+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))) MIDDLEDOT ; saw "[sign] {digit}+ dot" (ouch-read-buffer char) @@ -767,118 +758,124 @@ (unless char (return (let ((*read-base* 10)) (make-integer)))) (case (char-class char attribute-table) - (#.constituent-digit (go RIGHTDIGIT)) - (#.constituent-expt (go EXPONENT)) - (#.delimiter + (#.+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)))) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+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}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-float))) (case (char-class char attribute-table) - (#.constituent-digit (go RIGHTDIGIT)) - (#.constituent-expt (go EXPONENT)) - (#.delimiter (unread-char char stream) (return (make-float))) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+char-attr-constituent-digit+ (go RIGHTDIGIT)) + (#.+char-attr-constituent-expt+ (go EXPONENT)) + (#.+char-attr-delimiter+ + (unread-char char stream) + (return (make-float))) + (#.+char-attr-escape+ (go 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) - (#.constituent-digit (go RIGHTDIGIT)) - (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) + (#.+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))) 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) - (#.constituent-digit (go RIGHTDIGIT)) - (#.constituent-dot (go DOTS)) - (#.delimiter (%reader-error stream "dot context error")) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+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))) EXPONENT (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table) - (#.constituent-sign (go EXPTSIGN)) - (#.constituent-digit (go EXPTDIGIT)) - (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+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))) 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) - (#.constituent-digit (go EXPTDIGIT)) - (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+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))) EXPTDIGIT ; got to EXPONENT, saw "[sign] {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-float))) (case (char-class char attribute-table) - (#.constituent-digit (go EXPTDIGIT)) - (#.delimiter (unread-char char stream) (return (make-float))) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+char-attr-constituent-digit+ (go EXPTDIGIT)) + (#.+char-attr-delimiter+ + (unread-char char stream) + (return (make-float))) + (#.+char-attr-escape+ (go 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) - (#.constituent-digit (go RATIODIGIT)) - (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+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))) RATIODIGIT ; saw "[sign] {digit}+ slash {digit}+" (ouch-read-buffer char) (setq char (read-char stream nil nil)) (unless char (return (make-ratio))) (case (char-class2 char attribute-table) - (#.constituent-digit (go RATIODIGIT)) - (#.delimiter (unread-char char stream) (return (make-ratio))) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+char-attr-constituent-digit+ (go RATIODIGIT)) + (#.+char-attr-delimiter+ + (unread-char char stream) + (return (make-ratio))) + (#.+char-attr-escape+ (go 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) - (#.constituent-dot (go DOTS)) - (#.delimiter + (#.+char-attr-constituent-dot+ (go DOTS)) + (#.+char-attr-delimiter+ (unread-char char stream) (%reader-error stream "too many dots")) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+char-attr-escape+ (go 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))) @@ -890,15 +887,15 @@ (setq char (fast-read-char nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table) - (#.escape (done-with-fast-read-char) - (go ESCAPE)) - (#.delimiter (done-with-fast-read-char) - (unread-char char stream) - (go RETURN-SYMBOL)) - (#.multiple-escape (done-with-fast-read-char) - (go MULT-ESCAPE)) - (#.package-delimiter (done-with-fast-read-char) - (go COLON)) + (#.+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 () @@ -907,11 +904,11 @@ (setq char (stream-read-char stream)) (when (eq char :eof) (go RETURN-SYMBOL)) (case (char-class char attribute-table) - (#.escape (go ESCAPE)) - (#.delimiter (stream-unread-char stream char) + (#.+char-attr-escape+ (go ESCAPE)) + (#.+char-attr-delimiter+ (stream-unread-char stream char) (go RETURN-SYMBOL)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+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. @@ -924,10 +921,10 @@ (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table) - (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+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))) MULT-ESCAPE (do ((char (read-char stream t) (read-char stream t))) @@ -938,10 +935,10 @@ (setq char (read-char stream nil nil)) (unless char (go RETURN-SYMBOL)) (case (char-class char attribute-table) - (#.delimiter (unread-char char stream) (go RETURN-SYMBOL)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go COLON)) + (#.+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))) COLON (casify-read-buffer escapes) @@ -963,14 +960,14 @@ (setq char (read-char stream nil nil)) (unless char (reader-eof-error stream "after reading a colon")) (case (char-class char attribute-table) - (#.delimiter + (#.+char-attr-delimiter+ (unread-char char stream) (%reader-error stream "illegal terminating character after a colon: ~S" char)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter (go INTERN)) + (#.+char-attr-escape+ (go ESCAPE)) + (#.+char-attr-multiple-escape+ (go MULT-ESCAPE)) + (#.+char-attr-package-delimiter+ (go INTERN)) (t (go SYMBOL))) INTERN (setq colons 2) @@ -978,14 +975,14 @@ (unless char (reader-eof-error stream "after reading a colon")) (case (char-class char attribute-table) - (#.delimiter + (#.+char-attr-delimiter+ (unread-char char stream) (%reader-error stream "illegal terminating character after a colon: ~S" char)) - (#.escape (go ESCAPE)) - (#.multiple-escape (go MULT-ESCAPE)) - (#.package-delimiter + (#.+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)) @@ -1281,7 +1278,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*))