From 1e84b68ce9baada2c03802da5f2ce7f21a3ca171 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 2 May 2007 15:35:15 +0000 Subject: [PATCH] 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.) --- src/pcl/boot.lisp | 50 +++++++++++++++++++++++++--------------------- tests/mop-26.impure.lisp | 36 +++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 3 files changed, 64 insertions(+), 24 deletions(-) create mode 100644 tests/mop-26.impure.lisp diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index d995810..fbfdbe8 100644 --- 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 - "~@" - specializer + "~@" + 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 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 --- 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" -- 1.7.10.4