index 4dba26e..558afc4 100644 (file)
--- a/src/code/reader.lisp
+++ b/src/code/reader.lisp
@@ -314,12 +314,19 @@ standard Lisp readtable when NIL."
   ;; 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)))))
+         (dtable (find char dalist :test #'char= :key #'car)))
+    (if dtable
+       ;; 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 dtable) (make-char-dispatch-table))
+       (setf (dispatch-tables rt)
+             (push (cons char (make-char-dispatch-table)) dalist))))
   t)
 
 (defun set-dispatch-macro-character (disp-char sub-char function
diff --git a/tests/reader.impure.lisp b/tests/reader.impure.lisp
index e3782b8..6ceadbd 100644 (file)
--- a/tests/reader.impure.lisp
+++ b/tests/reader.impure.lisp
@@ -125,6 +125,13 @@
   (funcall fun)
   (assert (equal '(:ok) (read-from-string "{:ok)"))))
 
+;; Test that invoking MAKE-DISPATCH-MACRO-CHARACTER twice on the same
+;; character clears the dispatch table.
+(with-test (:name make-dispatch-macro-character-twice)
+  (let ((*readtable* (copy-readtable)))
+    (assert (make-dispatch-macro-character #\#))
+    (assert (not (get-dispatch-macro-character #\# #\')))))
+
 (with-test (:name standard-readtable-modified)
   (macrolet ((test (form &optional op)
                `(assert