+ (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))
+
+(defmethod shared-initialize :after
+ ((slotd structure-slot-definition) slot-names &key
+ (allocation :instance) allocation-class)
+ (declare (ignore slot-names allocation-class))
+ (unless (eq allocation :instance)
+ (error "Structure slots must have :INSTANCE allocation.")))
+
+(defun make-structure-class-defstruct-form (name direct-slots include)
+ (let* ((conc-name (format-symbol *package* "~S structure class " name))
+ (constructor (format-symbol *package* "~Aconstructor" conc-name))
+ (defstruct `(defstruct (,name
+ ,@(when include
+ `((:include ,(class-name include))))
+ (:predicate nil)
+ (:conc-name ,conc-name)
+ (:constructor ,constructor ())
+ (:copier nil))
+ ,@(mapcar (lambda (slot)
+ `(,(slot-definition-name slot)
+ +slot-unbound+))
+ direct-slots)))
+ (reader-names (mapcar (lambda (slotd)
+ (list 'slot-accessor name
+ (slot-definition-name slotd)
+ 'reader))
+ direct-slots))
+ (writer-names (mapcar (lambda (slotd)
+ (list 'slot-accessor name
+ (slot-definition-name slotd)
+ 'writer))
+ direct-slots))
+ (readers-init
+ (mapcar (lambda (slotd reader-name)
+ (let ((accessor
+ (slot-definition-defstruct-accessor-symbol
+ slotd)))
+ `(defun ,reader-name (obj)
+ (declare (type ,name obj))
+ (,accessor obj))))
+ direct-slots reader-names))
+ (writers-init
+ (mapcar (lambda (slotd writer-name)
+ (let ((accessor
+ (slot-definition-defstruct-accessor-symbol
+ slotd)))
+ `(defun ,writer-name (nv obj)
+ (declare (type ,name obj))
+ (setf (,accessor obj) nv))))
+ direct-slots writer-names))
+ (defstruct-form
+ `(progn
+ ,defstruct
+ ,@readers-init ,@writers-init
+ (cons nil nil))))
+ (values defstruct-form constructor reader-names writer-names)))
+
+(defun make-defstruct-allocation-function (class)
+ (let ((dd (get-structure-dd (class-name class))))
+ (lambda ()
+ (sb-kernel::%make-instance-with-layout
+ (sb-kernel::compiler-layout-or-lose (dd-name dd))))))