+ ;; NON-TERMINATING-P return value:
+ (if fun-value
+ (or (constituentp char designated-readtable)
+ (not (terminating-macrop char designated-readtable)))
+ ;; 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))))
+
+
+(defun make-char-dispatch-table ()
+ (make-hash-table))
+
+(defun make-dispatch-macro-character (char &optional
+ (non-terminating-p nil)
+ (rt *readtable*))
+ #!+sb-doc
+ "Cause CHAR to become a dispatching macro character in readtable (which
+ defaults to the current readtable). If NON-TERMINATING-P, the char will
+ 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 (cdr (find char dalist :test #'char= :key #'car))))
+ (cond (dtable
+ (error "The dispatch character ~S already exists." char))
+ (t
+ (setf (dispatch-tables rt)
+ (push (cons char (make-char-dispatch-table)) dalist)))))
+ t)
+
+(defun set-dispatch-macro-character (disp-char sub-char function
+ &optional (rt-designator *readtable*))
+ #!+sb-doc
+ "Cause FUNCTION to be called whenever the reader reads DISP-CHAR
+ followed by SUB-CHAR."
+ ;; Get the dispatch char for macro (error if not there), diddle
+ ;; entry for sub-char.
+ (let* ((sub-char (char-upcase sub-char))
+ (readtable (or rt-designator *standard-readtable*)))
+ (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)))
+ (if dpair
+ (setf (gethash sub-char (cdr dpair)) (coerce function 'function))
+ (error "~S is not a dispatch char." disp-char))))
+ t)
+
+(defun get-dispatch-macro-character (disp-char sub-char
+ &optional (rt-designator *readtable*))
+ #!+sb-doc
+ "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))
+ (readtable (or rt-designator *standard-readtable*))
+ (dpair (find disp-char (dispatch-tables readtable)
+ :test #'char= :key #'car)))
+ (if dpair
+ (values (gethash sub-char (cdr dpair)))
+ (error "~S is not a dispatch char." disp-char))))
+