From 88e9e177e7ca72d660a3335d63895a1e0f71a5f8 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Fri, 18 Nov 2005 17:12:42 +0000 Subject: [PATCH] 0.9.6.51: Fix bug reported by Kalle Olavi Niemitalo on comp.lang.lisp ... create CONDITION-CLASSes for DEFINE-CONDITION forms eagerly. ... oh, but wait. CONDITION-CLASSes are already created as part of the reader/writer generation, for those condition classes with slots, in the (find-class condition) incantation of install-condition-fooer-function. ... and oh joy, reinitialize-instance on condition-classes removes accessors but does not add them again. Add a reinitialize-instance :after method to put them back. ... add a comment explaining that I have no idea what is meant to happen. (CMUCL has a bogus CLASS-DIRECT-SLOTS on condition instances, which explains somewhat why it seems to work there...) --- NEWS | 3 +++ src/code/condition.lisp | 7 ++++++- src/pcl/braid.lisp | 5 +++-- src/pcl/std-class.lisp | 23 +++++++++++++++++++++++ tests/mop.impure.lisp | 17 +++++++++++++++++ version.lisp-expr | 2 +- 6 files changed, 53 insertions(+), 4 deletions(-) diff --git a/NEWS b/NEWS index 73fc7a7..66c6365 100644 --- a/NEWS +++ b/NEWS @@ -20,6 +20,9 @@ changes in sbcl-0.9.7 relative to sbcl-0.9.6: * bug fix: the dependent update protocol now works for generic functions. (thanks to Gerd Moellmann; reported by Bruno Haible and Pascal Costanza) + * bug fix: condition-class instances corresponding to + DEFINE-CONDITION forms are now created eagerly. (reported by + Kalle Olavi Niemitalo on comp.lang.lisp) * bug fix: floating point printing is more accurate in some circumstances. (thanks to Simon Alexander) * bug fix: *COMPILE-FILE-PATHNAME* now contains the user's pathname diff --git a/src/code/condition.lisp b/src/code/condition.lisp index 32db3f7..ae93468 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -391,6 +391,8 @@ (lambda (new-value condition) (condition-writer-function condition new-value slot-name)))) +(defvar *define-condition-hooks* nil) + (defun %define-condition (name parent-types layout slots documentation report default-initargs all-readers all-writers source-location) @@ -440,7 +442,10 @@ (dolist (initarg (condition-slot-initargs slot) nil) (when (functionp (getf e-def-initargs initarg)) (return t)))) - (push slot (condition-classoid-hairy-slots class)))))))) + (push slot (condition-classoid-hairy-slots class))))))) + (when (boundp '*define-condition-hooks*) + (dolist (fun *define-condition-hooks*) + (funcall fun class)))) name)) (defmacro define-condition (name (&rest parent-types) (&rest slot-specs) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 9955583..9983c49 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -588,14 +588,15 @@ (t (error "~@<~S is not the name of a class.~@:>" name))))) -(defun ensure-defstruct-class (classoid) +(defun ensure-deffoo-class (classoid) (let ((class (classoid-pcl-class classoid))) (cond (class (ensure-non-standard-class (class-name class) class)) ((eq 'complete *boot-state*) (ensure-non-standard-class (classoid-name classoid)))))) -(pushnew 'ensure-defstruct-class sb-kernel::*defstruct-hooks*) +(pushnew 'ensure-deffoo-class sb-kernel::*defstruct-hooks*) +(pushnew 'ensure-deffoo-class sb-kernel::*define-condition-hooks*) (defun make-class-predicate (class name) (let* ((gf (ensure-generic-function name :lambda-list '(object))) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 4caecc6..85dd173 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -514,6 +514,21 @@ (lambda (dependent) (apply #'update-dependent class dependent initargs)))) +(defmethod reinitialize-instance :after ((class condition-class) &key) + (let* ((name (class-name class)) + (classoid (find-classoid name)) + (slots (condition-classoid-slots classoid))) + ;; to balance the REMOVE-SLOT-ACCESSORS call in + ;; REINITIALIZE-INSTANCE :BEFORE (SLOT-CLASS). + (dolist (slot slots) + (let ((slot-name (condition-slot-name slot))) + (dolist (reader (condition-slot-readers slot)) + ;; FIXME: see comment in SHARED-INITIALIZE :AFTER + ;; (CONDITION-CLASS T), below. -- CSR, 2005-11-18 + (sb-kernel::install-condition-slot-reader reader name slot-name)) + (dolist (writer (condition-slot-writers slot)) + (sb-kernel::install-condition-slot-writer writer name slot-name)))))) + (defmethod shared-initialize :after ((class condition-class) slot-names &key direct-slots direct-superclasses) (declare (ignore slot-names)) @@ -540,6 +555,14 @@ ;; We don't ADD-SLOT-ACCESSORS here because we don't want to ;; override condition accessors with generic functions. We do this ;; differently. + ;; + ;; ??? What does the above comment mean and why is it a good idea? + ;; CMUCL (which still as of 2005-11-18 uses this code and has this + ;; comment) loses slot information in its condition classes: + ;; DIRECT-SLOTS is always NIL. We have the right information, so we + ;; remove slot accessors but never put them back. I've added a + ;; REINITIALIZE-INSTANCE :AFTER (CONDITION-CLASS) method, but what + ;; was meant to happen? -- CSR, 2005-11-18 (update-pv-table-cache-info class)) (defmethod direct-slot-definition-class ((class condition-class) diff --git a/tests/mop.impure.lisp b/tests/mop.impure.lisp index 7b33665..6b35e3b 100644 --- a/tests/mop.impure.lisp +++ b/tests/mop.impure.lisp @@ -382,6 +382,23 @@ (let ((subs (sb-mop:class-direct-subclasses (find-class 'bug-331-super)))) (assert (= 1 (length subs))) (assert (eq (car subs) (find-class 'bug-331-sub)))) +;;; (addendum to test for #331: conditions suffered the same problem) +(define-condition condition-bug-331-super () ()) +(define-condition condition-bug-331-sub (condition-bug-331-super) ()) +(let ((subs (sb-mop:class-direct-subclasses + (find-class 'condition-bug-331-super)))) + (assert (= 1 (length subs))) + (assert (eq (car subs) (find-class 'condition-bug-331-sub)))) +;;; (addendum to the addendum: the fix for this revealed breakage in +;;; REINITIALIZE-INSTANCE) +(define-condition condition-bug-331a () ((slot331a :reader slot331a))) +(reinitialize-instance (find-class 'condition-bug-331a)) +(let* ((gf #'slot331a) + (methods (sb-mop:generic-function-methods gf))) + (assert (= (length methods) 1)) + (assert (eq (car methods) + (find-method #'slot331a nil + (list (find-class 'condition-bug-331a)))))) ;;; detection of multiple class options in defclass, reported by Bruno Haible (defclass option-class (standard-class) diff --git a/version.lisp-expr b/version.lisp-expr index 8349969..31083f3 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.6.50" +"0.9.6.51" -- 1.7.10.4