index 558afc4..569a78c 100644 (file)
--- a/src/code/reader.lisp
+++ b/src/code/reader.lisp
@@ -108,6 +108,12 @@
   (unless *read-suppress*
     (simple-reader-error stream "undefined read-macro character ~S" char)))
 
+(declaim (inline get-dtable-pair))
+(defun get-dtable-pair (char readtable)
+  (find char (dispatch-tables readtable)
+       :test #'(lambda (x y) (char= x y)) ; avoid &REST list allocation.
+       :key #'car))
+
 ;;; The character attribute table is a CHAR-CODE-LIMIT vector of integers.
 
 (defmacro test-attribute (char whichclass rt)
@@ -244,10 +250,8 @@ standard Lisp readtable when NIL."
   (let ((really-from-readtable (or from-readtable *standard-readtable*)))
     (let ((att (get-cat-entry from-char really-from-readtable))
           (mac (get-raw-cmt-entry from-char really-from-readtable))
-          (from-dpair (find from-char (dispatch-tables really-from-readtable)
-                            :test #'char= :key #'car))
-          (to-dpair (find to-char (dispatch-tables to-readtable)
-                          :test #'char= :key #'car)))
+          (from-dpair (get-dtable-pair from-char really-from-readtable))
+          (to-dpair (get-dtable-pair to-char to-readtable)))
       (set-cat-entry to-char att to-readtable)
       (set-cmt-entry to-char mac to-readtable)
       (when from-dpair
@@ -257,10 +261,9 @@ standard Lisp readtable when NIL."
              (clrhash table)
              (shallow-replace/eql-hash-table table (cdr from-dpair))))
           (t
-           (let ((pair (cons to-char (make-hash-table))))
-             (shallow-replace/eql-hash-table (cdr pair) (cdr from-dpair))
-             (setf (dispatch-tables to-readtable)
-                   (push pair (dispatch-tables to-readtable)))))))))
+           (let ((new-table (make-char-dispatch-table)))
+             (shallow-replace/eql-hash-table new-table (cdr from-dpair))
+             (push (cons to-char new-table) (dispatch-tables to-readtable))))))))
   t)
 
 (defun set-macro-character (char function &optional
@@ -290,10 +293,9 @@ 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
-                (or (constituentp char)
-                    (not (terminating-macrop 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
@@ -313,9 +315,8 @@ standard Lisp readtable when NIL."
    be non-terminating."
   ;; Checks already for standard readtable modification.
   (set-macro-character char #'read-dispatch-char non-terminating-p rt)
-  (let* ((dalist (dispatch-tables rt))
-         (dtable (find char dalist :test #'char= :key #'car)))
-    (if dtable
+  (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
@@ -324,9 +325,8 @@ standard Lisp readtable when NIL."
        ;; 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 dtable) (make-char-dispatch-table))
-       (setf (dispatch-tables rt)
-             (push (cons char (make-char-dispatch-table)) dalist))))
+       (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
@@ -341,10 +341,10 @@ standard Lisp readtable when NIL."
     (assert-not-standard-readtable readtable 'set-dispatch-macro-character)
     (when (digit-char-p sub-char)
       (error "SUB-CHAR must not be a decimal digit: ~S" sub-char))
-    (let ((dpair (find disp-char (dispatch-tables readtable)
-                       :test #'char= :key #'car)))
+    (let ((dpair (get-dtable-pair disp-char readtable)))
       (if dpair
-          (setf (gethash sub-char (cdr dpair)) (coerce function 'function))
+          (setf (gethash sub-char (cdr dpair))
+               (%coerce-callable-to-fun function))
           (error "~S is not a dispatch char." disp-char))))
   t)
 
@@ -355,8 +355,7 @@ standard Lisp readtable when NIL."
    or NIL if there is no associated function."
   (let* ((sub-char  (char-upcase sub-char))
          (readtable (or rt-designator *standard-readtable*))
-         (dpair     (find disp-char (dispatch-tables readtable)
-                          :test #'char= :key #'car)))
+         (dpair     (get-dtable-pair disp-char readtable)))
     (if dpair
         (values (gethash sub-char (cdr dpair)))
         (error "~S is not a dispatch char." disp-char))))
@@ -1520,8 +1519,7 @@ variables to allow for nested and thread safe reading."
       (setq numargp t)
       (setq numarg (+ (* numarg 10) dig)))
     ;; Look up the function and call it.
-    (let ((dpair (find char (dispatch-tables *readtable*)
-                       :test #'char= :key #'car)))
+    (let ((dpair (get-dtable-pair char *readtable*)))
       (if dpair
           (funcall (the function
                      (gethash sub-char (cdr dpair) #'dispatch-char-error))