- (setf (elt (character-attribute-table rt)
- (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)))
+ (if (typep char 'base-char)
+ (setf (elt (character-attribute-array rt) (char-code char)) newvalue)
+ ;; FIXME: could REMHASH if we're setting to
+ ;; +CHAR-ATTR-CONSTITUENT+
+ (setf (gethash char (character-attribute-hash-table rt)) newvalue)))
+
+;;; 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)
+ `(if (typep ,char 'base-char)
+ (svref (character-macro-array ,readtable) (char-code ,char))
+ ;; Note: DEFAULT here is NIL, not #'UNDEFINED-MACRO-CHAR, so
+ ;; that everything above the base-char range is a non-macro
+ ;; constituent by default.
+ (gethash ,char (character-macro-hash-table ,readtable) nil))))
+
+;;; 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*))
+ (if (typep char 'base-char)
+ (setf (svref (character-macro-array rt) (char-code char))
+ (and new-value-designator
+ (%coerce-callable-to-fun new-value-designator)))
+ (setf (gethash char (character-macro-hash-table rt))
+ (and new-value-designator
+ (%coerce-callable-to-fun new-value-designator)))))