1.0.5.20: make class-eq specializers work in defmethods

	Mostly for consistency: this is not an exported extension or
	anything.  But it was gratuitously broken before, and it was
	also broken in ways preventing user-defined specializers from
	working.  So fix it and test it, with a comment saying that it's
	OK to break it deliberately.

	(User-defined specializers do not currently work, even after
	this change.)

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index d995810..fbfdbe8 100644 (file)
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -606,31 +606,35 @@ bootstrapping.
          ;; We still need to deal with the class case too, but at
          ;; least #.(find-class 'integer) and integer as equivalent
          ;; specializers with this.
-         (let* ((specializer (if (and (typep specializer 'class)
-                                      (let ((name (class-name specializer)))
-                                        (and name (symbolp name)
-                                             (eq specializer (find-class name nil)))))
-                                 (class-name specializer)
-                                 specializer))
-                (kind (info :type :kind specializer)))
-
-           (flet ((specializer-class ()
-                    (if (typep specializer 'class)
-                        specializer
-                        (find-class specializer nil))))
+         (let* ((specializer-nameoid
+                 (if (and (typep specializer 'class)
+                          (let ((name (class-name specializer)))
+                            (and name (symbolp name)
+                                 (eq specializer (find-class name nil)))))
+                     (class-name specializer)
+                     specializer))
+                (kind (info :type :kind specializer-nameoid)))
+
+           (flet ((specializer-nameoid-class ()
+                    (typecase specializer-nameoid
+                      (symbol (find-class specializer-nameoid nil))
+                      (class specializer-nameoid)
+                      (class-eq-specializer 
+                       (specializer-class specializer-nameoid))
+                      (t nil))))
              (ecase kind
-               ((:primitive) `(type ,specializer ,parameter))
+               ((:primitive) `(type ,specializer-nameoid ,parameter))
                ((:defined)
-                (let ((class (specializer-class)))
-                  ;; CLASS can be null here if the user has erroneously
-                 ;; tried to use a defined type as a specializer; it
-                 ;; can be a non-BUILT-IN-CLASS if the user defines a
-                 ;; type and calls (SETF FIND-CLASS) in a consistent
-                 ;; way.
+                (let ((class (specializer-nameoid-class)))
+                  ;; CLASS can be null here if the user has
+                  ;; erroneously tried to use a defined type as a
+                  ;; specializer; it can be a non-BUILT-IN-CLASS if
+                  ;; the user defines a type and calls (SETF
+                  ;; FIND-CLASS) in a consistent way.
                  (when (and class (typep class 'built-in-class))
-                   `(type ,specializer ,parameter))))
+                   `(type ,specializer-nameoid ,parameter))))
               ((:instance nil)
-               (let ((class (specializer-class)))
+               (let ((class (specializer-nameoid-class)))
                  (cond
                    (class
                     (if (typep class '(or built-in-class structure-class))
@@ -645,8 +649,8 @@ bootstrapping.
                     ;; ...)).  Best to let the user know we haven't
                     ;; been able to extract enough information:
                     (style-warn
-                     "~@<can't find type for presumed class ~S in ~S.~@:>"
-                     specializer
+                     "~@<can't find type for specializer ~S in ~S.~@:>"
+                     specializer-nameoid
                      'parameter-specializer-declaration-in-defmethod)
                     '(ignorable)))))
               ((:forthcoming-defclass-type)

diff --git a/tests/mop-26.impure.lisp b/tests/mop-26.impure.lisp
new file mode 100644 (file)
index 0000000..b70f923
--- /dev/null
+++ b/tests/mop-26.impure.lisp
@@ -0,0 +1,36 @@
+;;;; miscellaneous side-effectful tests of the MOP
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+;;; This isn't really a test of the MOP per se.  PCL historically has
+;;; a CLASS-EQ specializer, which it uses internally to achieve
+;;; certain effects.  There's no particular reason that it should be
+;;; exposed to the user, except that some people have asked for it at
+;;; some point; however, there is also no particular reason that code
+;;; using it should be gratuitously broken, as it was for a while by
+;;; the SB-PCL::PARAMETER-SPECIALIZER-DECLARATION-IN-DEFMETHOD
+;;; function.  So it's fine if this test starts failing, as long as
+;;; it's deliberate.
+
+(in-package "CL-USER")
+
+(defclass super () ())
+(defclass sub (super) ())
+
+(defgeneric test (x))
+
+(defmethod test ((x t)) nil)
+(let ((spec (sb-pcl::class-eq-specializer (find-class 'super))))
+  (eval `(defmethod test ((x ,spec)) t)))
+
+(assert (test (make-instance 'super)))
+(assert (null (test (make-instance 'sub))))

diff --git a/version.lisp-expr b/version.lisp-expr
index fb4b905..7aad286 100644 (file)
--- 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.5.19"
+"1.0.5.20"