index fd0a539..8814281 100644 (file) --- a/src/code/reader.lisp +++ b/src/code/reader.lisp @@ -59,17 +59,25 @@ \f ;;;; macros and functions for character tables +(declaim (inline ref-cat-entry)) +(defun ref-cat-entry (char cat-array cat-ht) + (declare (character char) (char-attr-table cat-array) (hash-table cat-ht)) + (declare (optimize speed)) + (if (typep char 'base-char) + (aref cat-array (char-code char)) + (the char-attr + (values (gethash char cat-ht +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+)))) + (ref-cat-entry char + (character-attribute-array rt) + (character-attribute-hash-table rt))) (defun set-cat-entry (char newvalue &optional (rt *readtable*)) - (declare (readtable rt)) + (declare (char-attr newvalue) (readtable rt)) (if (typep char 'base-char) - (setf (elt (character-attribute-array rt) (char-code char)) newvalue) + (setf (aref (character-attribute-array rt) (char-code char)) 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)) @@ -294,7 +302,7 @@ standard Lisp readtable when NIL." ;; character, or NIL otherwise (fun-value (get-raw-cmt-entry char designated-readtable))) (values fun-value - ;; NON-TERMINATING-P return value: + ;; NON-TERMINATING-P return value: (if fun-value (not (terminating-macrop char)) ;; ANSI's definition of GET-MACRO-CHARACTER says this @@ -319,16 +327,16 @@ standard Lisp readtable when NIL." (set-macro-character char #'read-dispatch-char non-terminating-p rt) (let ((dpair (get-dtable-pair char rt))) (if dpair - ;; The spec doesn't say anything about the case if CHAR is a - ;; dispatching macro character already. Previously, this - ;; signalled an error here. All other open source - ;; implementations I tested do not signal an error, but - ;; proceed and just overwrite CHAR's dispatch-tables---which - ;; is sensible as "Exceptional Situations" of M-D-M-C are - ;; "None." [Perhaps we should call CLRHASH here instead.] - ;; -- TCR, 2008-12-03. - (setf (cdr dpair) (make-char-dispatch-table)) - (push (cons char (make-char-dispatch-table)) (dispatch-tables rt)))) + ;; The spec doesn't say anything about the case if CHAR is a + ;; dispatching macro character already. Previously, this + ;; signalled an error here. All other open source + ;; implementations I tested do not signal an error, but + ;; proceed and just overwrite CHAR's dispatch-tables---which + ;; is sensible as "Exceptional Situations" of M-D-M-C are + ;; "None." [Perhaps we should call CLRHASH here instead.] + ;; -- TCR, 2008-12-03. + (setf (cdr dpair) (make-char-dispatch-table)) + (push (cons char (make-char-dispatch-table)) (dispatch-tables rt)))) t) (defun set-dispatch-macro-character (disp-char sub-char function @@ -379,11 +387,7 @@ standard Lisp readtable when NIL." (attribute-hash-table (character-attribute-hash-table *readtable*)) (char (fast-read-char t) (fast-read-char t))) - ((/= (the fixnum - (if (typep char 'base-char) - (aref attribute-array (char-code char)) - (gethash char attribute-hash-table - +char-attr-constituent+))) + ((/= (ref-cat-entry char attribute-array attribute-hash-table) +char-attr-whitespace+) (done-with-fast-read-char) char))) @@ -393,12 +397,8 @@ standard Lisp readtable when NIL." (character-attribute-hash-table *readtable*)) (char (read-char stream nil :eof) (read-char stream nil :eof))) ((or (eq char :eof) - (/= (the fixnum - (if (typep char 'base-char) - (aref attribute-array (char-code char)) - (gethash char attribute-hash-table - +char-attr-constituent+))) - +char-attr-whitespace+)) + (/= (ref-cat-entry char attribute-array attribute-hash-table) + +char-attr-whitespace+)) (if (eq char :eof) (error 'end-of-file :stream stream) char)))))) @@ -770,10 +770,7 @@ variables to allow for nested and thread safe reading." ;;; FIXME: why aren't these ATT-getting forms using GET-CAT-ENTRY? ;;; Because we've cached the readtable tables? (defmacro char-class (char attarray atthash) - `(let ((att (if (typep ,char 'base-char) - (aref ,attarray (char-code ,char)) - (gethash ,char ,atthash +char-attr-constituent+)))) - (declare (type char-attr att)) + `(let ((att (ref-cat-entry ,char ,attarray ,atthash))) (cond ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+) ((< att +char-attr-constituent+) att) @@ -785,10 +782,7 @@ variables to allow for nested and thread safe reading." ;;; Return the character class for CHAR, which might be part of a ;;; rational number. (defmacro char-class2 (char attarray atthash) - `(let ((att (if (typep ,char 'base-char) - (aref ,attarray (char-code ,char)) - (gethash ,char ,atthash +char-attr-constituent+)))) - (declare (type char-attr att)) + `(let ((att (ref-cat-entry ,char ,attarray ,atthash))) (cond ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+) ((< att +char-attr-constituent+) att) @@ -804,10 +798,7 @@ variables to allow for nested and thread safe reading." ;;; rational or floating number. (Assume that it is a digit if it ;;; could be.) (defmacro char-class3 (char attarray atthash) - `(let ((att (if (typep ,char 'base-char) - (aref ,attarray (char-code ,char)) - (gethash ,char ,atthash +char-attr-constituent+)))) - (declare (type char-attr att)) + `(let ((att (ref-cat-entry ,char ,attarray ,atthash))) (cond ((<= att +char-attr-terminating-macro+) +char-attr-delimiter+) ((< att +char-attr-constituent+) att)