From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Thu, 4 Dec 2008 16:50:14 +0000 (+0000)
Subject: 1.0.23.18: SET-[DISPATCH-]MACRO-CHARACTER fixes
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=9614655fcb31923424174c4f7a43d5affc8019ad;p=sbcl.git

1.0.23.18: SET-[DISPATCH-]MACRO-CHARACTER fixes

 * Patch by Tobias Ritterweiler, plus tests and making S-D-M-C return T.
---

diff --git a/NEWS b/NEWS
index ea6743c..18ebf92 100644
--- a/NEWS
+++ b/NEWS
@@ -8,6 +8,11 @@
     using UTF-8 as external format. (thanks to Luis Oliveira)
   * bug fix: errors from invalid fill-pointer values to (SETF FILL-POINTER)
     are signalled correctly. (thanks to Stas Boukarev)
+  * bug fix: SET-MACRO-CHARACTER accepts NIL as the readtable
+    designator. (thanks to Tobias Ritterweiler)
+  * bug fix: SET-DISPATCH-MACRO-CHARACTER accepts NIL as the readtable
+    designator, and returns T instead of the function. (thanks to
+    Tobias Ritterweiler)
 
 changes in sbcl-1.0.23 relative to 1.0.22:
   * enhancement: when disassembling method functions, disassembly
diff --git a/src/code/reader.lisp b/src/code/reader.lisp
index 2eb433a..9cd525b 100644
--- a/src/code/reader.lisp
+++ b/src/code/reader.lisp
@@ -97,13 +97,11 @@
         #'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)))))
+  (let ((new (when new-value-designator
+               (%coerce-callable-to-fun new-value-designator))))
+    (if (typep char 'base-char)
+        (setf (svref (character-macro-array rt) (char-code char)) new)
+        (setf (gethash char (character-macro-hash-table rt)) new))))
 
 (defun undefined-macro-char (stream char)
   (unless *read-suppress*
@@ -1470,7 +1468,8 @@ variables to allow for nested and thread safe reading."
                       :test #'char= :key #'car)))
     (if dpair
         (setf (gethash sub-char (cdr dpair)) (coerce function 'function))
-        (error "~S is not a dispatch char." disp-char))))
+        (error "~S is not a dispatch char." disp-char))
+    t))
 
 (defun get-dispatch-macro-character (disp-char sub-char
                                      &optional (rt *readtable*))
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index a7d9537..e6390c4 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -982,7 +982,7 @@
   (character character &optional readtable (or readtable null)) (eql t)
   ())
 
-(defknown set-macro-character (character callable &optional t readtable)
+(defknown set-macro-character (character callable &optional t (or readtable null))
   (eql t)
   (unsafe))
 (defknown get-macro-character (character &optional (or readtable null))
@@ -991,7 +991,7 @@
 (defknown make-dispatch-macro-character (character &optional t readtable)
   (eql t) ())
 (defknown set-dispatch-macro-character
-  (character character callable &optional readtable) function
+  (character character callable &optional (or readtable null)) (eql t)
   (unsafe))
 (defknown get-dispatch-macro-character
   (character character &optional (or readtable null)) (or callable null)
diff --git a/tests/reader.impure.lisp b/tests/reader.impure.lisp
index bb37bdf..02f202d 100644
--- a/tests/reader.impure.lisp
+++ b/tests/reader.impure.lisp
@@ -125,4 +125,13 @@
   (funcall fun)
   (assert (equal '(:ok) (read-from-string "{:ok)"))))
 
+;;; THIS SHOULD BE LAST as it frobs the standard readtable
+(with-test (:name set-macro-character-nil)
+  (let ((fun (lambda (&rest args) 'ok)))
+    ;; NIL means the standard readtable.
+    (assert (eq t (set-macro-character #\~ fun nil nil)))
+    (assert (eq fun (get-macro-character #\~ nil)))
+    (assert (eq t (set-dispatch-macro-character #\# #\~ fun nil)))
+    (assert (eq fun (get-dispatch-macro-character #\# #\~ nil)))))
+
 ;;; success
diff --git a/version.lisp-expr b/version.lisp-expr
index ef774c5..87780c0 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.23.17"
+"1.0.23.18"