+ (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))
+ (let ((classoid (find-classoid (class-name class))))
+ (with-slots (wrapper %class-precedence-list cpl-available-p
+ prototype (direct-supers direct-superclasses))
+ class
+ (setf (slot-value class 'direct-slots)
+ (mapcar (lambda (pl) (make-direct-slotd class pl))
+ direct-slots))
+ (setf (slot-value class 'finalized-p) t)
+ (setf (classoid-pcl-class classoid) class)
+ (setq direct-supers direct-superclasses)
+ (setq wrapper (classoid-layout classoid))
+ (setq %class-precedence-list (compute-class-precedence-list class))
+ (setq cpl-available-p t)
+ (add-direct-subclasses class direct-superclasses)
+ (setf (slot-value class 'slots) (compute-slots class))))
+ ;; Comment from Gerd's PCL, 2003-05-15:
+ ;;
+ ;; 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)
+ &rest initargs)
+ (declare (ignore initargs))
+ (find-class 'condition-direct-slot-definition))
+
+(defmethod effective-slot-definition-class ((class condition-class)
+ &rest initargs)
+ (declare (ignore initargs))
+ (find-class 'condition-effective-slot-definition))
+
+(defmethod finalize-inheritance ((class condition-class))
+ (aver (slot-value class 'finalized-p))
+ nil)
+
+(defmethod compute-effective-slot-definition
+ ((class condition-class) slot-name dslotds)
+ (let ((slotd (call-next-method)))
+ (setf (slot-definition-reader-function slotd)
+ (lambda (x)
+ (handler-case (condition-reader-function x slot-name)
+ ;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot
+ ;; is unbound; maybe it should be a CELL-ERROR of some
+ ;; sort?
+ (error () (values (slot-unbound class x slot-name))))))
+ (setf (slot-definition-writer-function slotd)
+ (lambda (v x)
+ (condition-writer-function x v slot-name)))
+ (setf (slot-definition-boundp-function slotd)
+ (lambda (x)
+ (multiple-value-bind (v c)
+ (ignore-errors (condition-reader-function x slot-name))
+ (declare (ignore v))
+ (null c))))
+ slotd))
+
+(defmethod compute-slots ((class condition-class))
+ (mapcan (lambda (superclass)
+ (mapcar (lambda (dslotd)
+ (compute-effective-slot-definition
+ class (slot-definition-name dslotd) (list dslotd)))
+ (class-direct-slots superclass)))
+ (reverse (slot-value class '%class-precedence-list))))
+
+(defmethod compute-slots :around ((class condition-class))
+ (let ((eslotds (call-next-method)))
+ (mapc #'initialize-internal-slot-functions eslotds)
+ eslotds))