From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Wed, 7 Jun 2006 19:08:30 +0000 (+0000)
Subject: 0.9.13.34: Class objects as specializers
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=992e6a70a0cae3f6d43bdbba18f77306fdf10662;p=sbcl.git

0.9.13.34: Class objects as specializers
 * As reported by Pascal Costanze on sbcl-devel.
 * Also record PCL code walker bug wrt. user-defined declarations.
---

diff --git a/BUGS b/BUGS
index 4860f07..01bae8d 100644
--- a/BUGS
+++ b/BUGS
@@ -2131,3 +2131,20 @@ WORKAROUND:
 
 401: "optimizer runaway on bad constant type specifiers in TYPEP"
   (fixed in 0.9.12.12)
+
+402: "DECLAIM DECLARATION does not inform the PCL code-walker"
+  reported by Vincent Arkesteijn:
+
+  (declaim (declaration foo))
+  (defgeneric bar (x))
+  (defmethod bar (x)
+    (declare (foo x))
+    x)
+
+  ==> WARNING: The declaration FOO is not understood by
+      SB-PCL::SPLIT-DECLARATIONS.
+      Please put FOO on one of the lists SB-PCL::*NON-VAR-DECLARATIONS*,
+      SB-PCL::*VAR-DECLARATIONS-WITH-ARG*, or
+      SB-PCL::*VAR-DECLARATIONS-WITHOUT-ARG*.
+      (Assuming it is a variable declaration without argument).
+
diff --git a/NEWS b/NEWS
index 3c7b436..bc5a8ea 100644
--- a/NEWS
+++ b/NEWS
@@ -15,6 +15,8 @@ changes in sbcl-0.9.14 relative to sbcl-0.9.13:
   * minor incompatibale change: the :SB-LDB feature is now enabled by
     default, and DISABLE-DEBUGGER and ENABLE-DEBUGGER also affect
     the low-level debugger.
+  * bug fix: class objects can be used as specializers in methods.
+    (reported by Pascal Costanza)
   * bug fix: native unparsing of pathnames with :DIRECTORY NIL failed
     with a type error. (reported by blitz_ on #lisp)
   * bug fix: unparsing logical pathnames with :NAME :WILD :TYPE NIL
diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 5d4f940..4cbefe1 100644
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -604,39 +604,58 @@ bootstrapping.
          '(ignorable))
         (t
          ;; Otherwise, we can usually make Python very happy.
-         (let ((kind (info :type :kind specializer)))
-           (ecase kind
-             ((:primitive) `(type ,specializer ,parameter))
-             ((:defined)
-              (let ((class (find-class specializer nil)))
-                ;; 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))))
-             ((:instance nil)
-              (let ((class (find-class specializer nil)))
-                (cond
-                  (class
-                   (if (typep class '(or built-in-class structure-class))
-                       `(type ,specializer ,parameter)
-                       ;; don't declare CLOS classes as parameters;
-                       ;; it's too expensive.
-                       '(ignorable)))
-                  (t
-                   ;; we can get here, and still not have a failure
-                   ;; case, by doing MOP programming like (PROGN
-                   ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO))
-                   ;; ...)).  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
-                    'parameter-specializer-declaration-in-defmethod)
-                   '(ignorable)))))
-             ((:forthcoming-defclass-type) '(ignorable)))))))
+         ;;
+         ;; KLUDGE: Since INFO doesn't work right for class objects here,
+         ;; and they are valid specializers, see if the specializer is
+         ;; a named class, and use the name in that case -- otherwise
+         ;; the class instance is ok, since info will just return NIL, NIL.
+         ;;
+         ;; 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)
+                                      (eq specializer (find-class (class-name specializer))))
+                                 (class-name specializer)
+                                 specializer))
+                (kind (info :type :kind specializer)))
+
+           (flet ((specializer-class ()
+                    (if (typep specializer 'class)
+                        specializer
+                        (find-class specializer nil))))
+             (ecase kind
+               ((:primitive) `(type ,specializer ,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.
+                 (when (and class (typep class 'built-in-class))
+                   `(type ,specializer ,parameter))))
+              ((:instance nil)
+               (let ((class (specializer-class)))
+                 (cond
+                   (class
+                    (if (typep class '(or built-in-class structure-class))
+                        `(type ,specializer ,parameter)
+                        ;; don't declare CLOS classes as parameters;
+                        ;; it's too expensive.
+                        '(ignorable)))
+                   (t
+                    ;; we can get here, and still not have a failure
+                    ;; case, by doing MOP programming like (PROGN
+                    ;; (ENSURE-CLASS 'FOO) (DEFMETHOD BAR ((X FOO))
+                    ;; ...)).  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
+                     'parameter-specializer-declaration-in-defmethod)
+                    '(ignorable)))))
+              ((:forthcoming-defclass-type)
+               '(ignorable))))))))
 
 (defun make-method-lambda-internal (method-lambda &optional env)
   (unless (and (consp method-lambda) (eq (car method-lambda) 'lambda))
diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index d04a4c0..46749be 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -1280,5 +1280,16 @@
                   (slot-value test 'x))))
   (assert (= 13 (slot-value test 'x))))
 
+;;; Using class instances as specializers, reported by Pascal Costanza, ref CLHS 7.6.2
+(defclass class-as-specializer-test ()
+   ())
+(eval `(defmethod class-as-specializer-test1 ((x ,(find-class 'class-as-specializer-test)))
+          'foo))
+(assert (eq 'foo (class-as-specializer-test1 (make-instance 'class-as-specializer-test))))
+(funcall (compile nil `(lambda ()
+                         (defmethod class-as-specializer-test2 ((x ,(find-class 'class-as-specializer-test)))
+                           'bar))))
+(assert (eq 'bar (class-as-specializer-test2 (make-instance 'class-as-specializer-test))))
+
 
 ;;;; success
diff --git a/version.lisp-expr b/version.lisp-expr
index 5f41a32..0bbdf18 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".)
-"0.9.13.33"
+"0.9.13.34"