- (gensym "UNBOUND-SLOT-")))
-
-(defun ensure-description-for-class (class &optional (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class)))))
- (let ((desc-class
- (ensure-class (defining-description name)
- :direct-superclasses (list (class-of (find-description 'standard-object)))
- :direct-slots (loop :for slot in (class-slots class)
- :collect `(:name ,(slot-definition-name slot)
- :attribute-class slot-definition-attribute
- :slot-name ,(slot-definition-name slot)
- :label ,(slot-definition-name slot))
- :into slots
+ +unbound-slot+))
+
+(defun attribute-slot-makunbound (attribute)
+ (slot-makunbound (attribute-object attribute) (attribute-slot-name attribute)))
+
+(defun ensure-description-for-class (class &key attributes (name (intern (format nil "DESCRIPTION-FOR-~A" (class-name class))))
+ direct-superclasses direct-slot-specs)
+
+ (let* ((super-descriptions
+ (mapcar #'class-of
+ (delete nil (mapcar (rcurry #'find-description nil)
+ (mapcar #'class-name direct-superclasses)))))
+ (desc-class
+ (ensure-layer (defining-description name)
+ :direct-superclasses (or super-descriptions (list (class-of (find-description 'standard-object))))
+ :direct-slots
+ (loop
+ :for slot in (class-slots class)
+ :collect
+ (let ((direct-spec
+ (find (slot-definition-name slot)
+ direct-slot-specs
+ :key (rcurry 'getf :name))))
+ (if direct-spec
+ (append (alexandria:remove-from-plist direct-spec
+ :initfunction
+ :initform
+ :initargs
+ :readers
+ :writers)
+ (unless
+ (getf direct-spec :attribute-class)
+ (list :attribute-class 'slot-definition-attribute))
+ (unless
+ (getf direct-spec :label)
+ (list :label (format nil
+ "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot))))))
+ (list :slot-name (slot-definition-name slot)))
+ `(:name ,(slot-definition-name slot)
+ :attribute-class slot-definition-attribute
+ :slot-name ,(slot-definition-name slot)
+ :label ,(format nil
+ "~@(~A~)" (substitute #\Space #\- (symbol-name (slot-definition-name slot)))))))
+ :into slots