From 0a1374c92d909493e8c20744d08025a346069f42 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 5 Jul 2004 22:00:43 +0000 Subject: [PATCH] 0.8.12.24: Stomping on a PCL buglet * Initialization of condition class metaobjects no longer creates an instance of the condition. (reported by Marco Baringer on sbcl-devel 2004-07-05) * Test for the same. --- NEWS | 3 +++ src/pcl/std-class.lisp | 5 ++++- tests/condition.impure.lisp | 9 +++++++++ version.lisp-expr | 2 +- 4 files changed, 17 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index 730e1d1..a813f36 100644 --- a/NEWS +++ b/NEWS @@ -9,6 +9,9 @@ changes in sbcl-0.8.13 relative to sbcl-0.8.12: an implementation-internal package. * the SB-SPROF contrib now works on (most) non-x86 architectures. It is known as of this release not to work on the Alpha, however. + * fixed bug: initialization of condition class metaobjects no longer + causes an instance of the condition to be created. (reported by Marco + Baringer) * fixed bug #338: instances of EQL-SPECIFIER are now valid type designators and can hence be used with TYPEP. * fixed bug #333: CHECK-TYPE now ensures that the type error diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 5a86391..382a235 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -133,6 +133,10 @@ (allocate-instance class) (allocate-standard-instance wrapper)))))) +(defmethod class-prototype ((class condition-class)) + (with-slots (prototype) class + (or prototype (setf prototype (allocate-instance class))))) + (defmethod class-direct-default-initargs ((class slot-class)) (plist-value class 'direct-default-initargs)) @@ -594,7 +598,6 @@ (setq direct-supers direct-superclasses) (setq wrapper (classoid-layout classoid)) (setq class-precedence-list (compute-class-precedence-list class)) - (setq prototype (make-condition (class-name class))) (add-direct-subclasses class direct-superclasses) (setq predicate-name (make-class-predicate-name (class-name class))) (make-class-predicate class predicate-name) diff --git a/tests/condition.impure.lisp b/tests/condition.impure.lisp index 03145a7..b454b4b 100644 --- a/tests/condition.impure.lisp +++ b/tests/condition.impure.lisp @@ -37,5 +37,14 @@ (assert (eql (code-msg code) 2)) (assert (eql (%code-msg code) 1))) +;;; Check that initializing the condition class metaobject doesn't create +;;; any instances. Reported by Marco Baringer on sbcl-devel Mon, 05 Jul 2004. +(defvar *condition-count* 0) +(define-condition counted-condition () ((slot :initform (incf *condition-count*)))) +(defmethod frob-counted-condition ((x counted-condition)) x) +(assert (= 0 *condition-count*)) +(assert (typep (sb-mop:class-prototype (find-class 'counted-condition)) + '(and condition counted-condition))) + ;;; success (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 5057a74..7f3e3a5 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.8.12.23" +"0.8.12.24" -- 1.7.10.4