1 (in-package :lisp-on-lines
)
3 (defstruct unbound-slot-value
(s))
5 (defvar +unbound-slot
+ (make-unbound-slot-value))
7 (defmethod print-object ((object unbound-slot-value
) stream
)
8 (print-unreadable-object (object stream
)
9 (format stream
"UNBOUND")))
11 (define-description standard-object
()
13 (class-slots :label
"Slots"
14 :function
(compose 'class-slots
'class-of
))))
16 (define-layered-class slot-definition-attribute
(standard-attribute)
17 ((slot-name :initarg
:slot-name
:accessor attribute-slot-name
)))
19 (defmethod shared-initialize :around
((object slot-definition-attribute
)
21 (prog1 (call-next-method)
22 (unless (attribute-setter object
)
23 (setf (attribute-setter object
)
25 (setf (slot-value o
(attribute-slot-name object
)) v
))))))
28 (define-layered-method attribute-value-using-object
(object (attribute slot-definition-attribute
))
29 (if (slot-boundp object
(attribute-slot-name attribute
))
31 (slot-value object
(attribute-slot-name attribute
))
32 (gensym "UNBOUND-SLOT-")))
34 (defun ensure-description-for-class (class &optional
(name (intern (format nil
"DESCRIPTION-FOR-~A" (class-name class
)))))
36 (ensure-class (defining-description name
)
37 :direct-superclasses
(list (class-of (find-description 'standard-object
)))
38 :direct-slots
(loop :for slot in
(class-slots class
)
39 :collect
`(:name
,(slot-definition-name slot
)
40 :attribute-class slot-definition-attribute
41 :slot-name
,(slot-definition-name slot
)
42 :label
,(slot-definition-name slot
))
44 :collect
(slot-definition-name slot
) :into names
45 :finally
(return (cons `(:name active-attributes
48 :metaclass
'standard-description-class
)))
50 (unless (ignore-errors (find-description (class-name class
)))
51 (ensure-class (defining-description (class-name class
))
52 :direct-superclasses
(list desc-class
)
53 :metaclass
'standard-description-class
))
54 (find-description name
)))
57 (defclass described-class
()
60 (defmethod validate-superclass
61 ((class described-class
)
62 (superclass standard-class
))
65 (defmethod initialize-instance :after
((class described-class
) &rest initargs
&key
(direct-superclasses '()))
66 (declare (dynamic-extent initargs
))
67 (finalize-inheritance class
)
68 (ensure-description-for-class class
))
71 (defmethod reinitialize-instance :after
((class described-class
) &rest initargs
&key
(direct-superclasses '() direct-superclasses-p
))
72 (declare (dynamic-extent initargs
))
73 (finalize-inheritance class
)
74 (ensure-description-for-class class
))
77 (define-layered-method description-of
((object standard-object
))
78 (or (ignore-errors (find-description (class-name (class-of object
))))
79 (find-description 'standard-object
)))