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...)

diff --git a/NEWS b/NEWS
index 73fc7a7..66c6365 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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*)
 \f
 (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 (file)
--- 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 (file)
--- 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 (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".)
-"0.9.6.50"
+"0.9.6.51"