Permalink
Browse files

unbreak on SBCL versions later than 1.1.18

GET-MACRO-CHARACTER returns closures for dispatch macro characters.
Add a kludge to treat these closures equivalent when resolving
readtable conflicts.
  • Loading branch information...
1 parent 91265db commit 715ad7f6f22993d0faff552e10186e536444de96 @melisgl committed May 21, 2014
Showing with 54 additions and 5 deletions.
  1. +15 −0 cruft.lisp
  2. +6 −5 named-readtables.lisp
  3. +33 −0 tests/tests.lisp
View
@@ -103,6 +103,21 @@
(if (and (eq n1 :lambda) (eq n2 :lambda))
(eq fn1 fn2)
(equal n1 n2)))
+ #+ :sbcl
+ (let ((fn1 (ensure-function fn1))
+ (fn2 (ensure-function fn2)))
+ (or (eq fn1 fn2)
+ ;; After SBCL 1.1.18, for dispatch macro characters
+ ;; GET-MACRO-CHARACTER returns closures whose name is:
+ ;;
+ ;; (LAMBDA (STREAM CHAR) :IN SB-IMPL::%MAKE-DISPATCH-MACRO-CHAR)
+ ;;
+ ;; Treat all these closures equivalent.
+ (let ((n1 (sb-impl::%fun-name fn1))
+ (n2 (sb-impl::%fun-name fn2)))
+ (and (listp n1) (listp n2)
+ (find 'sb-impl::%make-dispatch-macro-char n1)
+ (find 'sb-impl::%make-dispatch-macro-char n2)))))
#+ :common-lisp
(eq (ensure-function fn1) (ensure-function fn2)))
View
@@ -341,14 +341,15 @@ guaranteed to be fresh, but may contain duplicates."
(to-readtable condition))))
(:documentation "Continuable.
-This condition is signaled during the merge process if a) a reader macro
-\(be it a macro character or the sub character of a dispatch macro
-character\) is both present in the source as well as the target readtable,
-and b) if and only if the two respective reader macro functions differ."))
+ This condition is signaled during the merge process if a reader
+ macro (be it a macro character or the sub character of a dispatch
+ macro character) is present in the both source and the target
+ readtable and the two respective reader macro functions differ."))
(defun check-reader-macro-conflict (from to char &optional subchar)
(flet ((conflictp (from-fn to-fn)
- (assert from-fn) ; if this fails, there's a bug in readtable iterators.
+ (assert from-fn ()
+ "Bug in readtable iterators or concurrent access?")
(and to-fn (not (function= to-fn from-fn)))))
(when (if subchar
(conflictp (%get-dispatch-macro-character char subchar from)
View
@@ -79,6 +79,14 @@
(defreadtable A-as-X
(:macro-char #\A #'read-A-as-X))
+(defreadtable A-dispatch
+ (:macro-char #\A :dispatch)
+ (:dispatch-macro-char #\A #\A #'read-A))
+
+(defreadtable A-dispatch-as-X
+ (:macro-char #\A :dispatch)
+ (:dispatch-macro-char #\A #\A #'read-A-as-X))
+
(defreadtable B
(:macro-char #\B #'read-B))
@@ -276,6 +284,31 @@
(merge-readtables-into (make-readtable) :standard 'sharp-paren))
t)
+(deftest reader-macro-conflict.5
+ (signals-condition-p 'reader-macro-conflict
+ (merge-readtables-into (make-readtable) 'A 'A-dispatch))
+ t)
+
+(deftest reader-macro-conflict.6
+ (signals-condition-p 'reader-macro-conflict
+ (merge-readtables-into (make-readtable) 'A-dispatch 'A))
+ t)
+
+(deftest reader-macro-conflict.7
+ (signals-condition-p 'reader-macro-conflict
+ (merge-readtables-into (make-readtable) 'A-dispatch 'A-dispatch-as-X))
+ t)
+
+(deftest reader-macro-conflict.8
+ (signals-condition-p 'reader-macro-conflict
+ (merge-readtables-into (make-readtable) 'A 'A))
+ nil)
+
+(deftest reader-macro-conflict.9
+ (signals-condition-p 'reader-macro-conflict
+ (merge-readtables-into (make-readtable) 'A-dispatch 'A-dispatch))
+ nil)
+
(deftest readtable-does-not-exist.1
(signals-condition-p 'readtable-does-not-exist

2 comments on commit 715ad7f

This code now breaks on 1.1.18:

; caught ERROR:
;   READ error during COMPILE-FILE: Lock on package SB-IMPL
;   violated when interning %MAKE-DISPATCH-MACRO-CHAR while in
;   package EDITOR-HINTS.NAMED-READTABLES.
Owner

melisgl replied May 22, 2014

Please sign in to comment.