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
18 :accessor attribute-slot-name
21 (defmethod shared-initialize :around
((object slot-definition-attribute
)
23 (prog1 (call-next-method)
24 (unless (attribute-setter object
)
25 (setf (attribute-setter object
)
27 (setf (slot-value o
(attribute-slot-name object
)) v
))))))
30 (define-layered-method attribute-value-using-object
(object (attribute slot-definition-attribute
))
31 (if (slot-boundp object
(attribute-slot-name attribute
))
33 (slot-value object
(attribute-slot-name attribute
))
36 (defun attribute-slot-makunbound (attribute)
37 (slot-makunbound (attribute-object attribute
) (attribute-slot-name attribute
)))
39 (defun ensure-description-for-class (class &key attributes
(name (intern (format nil
"DESCRIPTION-FOR-~A" (class-name class
))))
40 direct-superclasses direct-slot-specs
)
42 (let* ((super-descriptions
44 (delete nil
(mapcar (rcurry #'find-description nil
)
45 (mapcar #'class-name direct-superclasses
)))))
47 (ensure-class (defining-description name
)
48 :direct-superclasses
(or super-descriptions
(list (class-of (find-description 'standard-object
))))
51 :for slot in
(class-slots class
)
54 (find (slot-definition-name slot
)
56 :key
(rcurry 'getf
:name
))))
58 (append (alexandria:remove-from-plist direct-spec
65 (getf direct-spec
:attribute-class
)
66 (list :attribute-class
'slot-definition-attribute
))
68 (getf direct-spec
:label
)
69 (list :label
(format nil
70 "~@(~A~)" (substitute #\Space
#\-
(symbol-name (slot-definition-name slot
))))))
71 (list :slot-name
(slot-definition-name slot
)))
72 `(:name
,(slot-definition-name slot
)
73 :attribute-class slot-definition-attribute
74 :slot-name
,(slot-definition-name slot
)
76 "~@(~A~)" (substitute #\Space
#\-
(symbol-name (slot-definition-name slot
)))))))
78 :collect
(slot-definition-name slot
) :into names
79 :finally
(return (cons `(:name active-attributes
80 :value
',(or attributes names
))
82 :metaclass
'standard-description-class
)))
83 (unless (ignore-errors (find-description (class-name class
)))
84 (ensure-class (defining-description (class-name class
))
85 :direct-superclasses
(list desc-class
)
86 :metaclass
'standard-description-class
))
87 (find-description name
)))
90 (defclass described-class
()
91 ((direct-slot-specs :accessor class-direct-slot-specs
)
92 (attributes :initarg
:attributes
:initform nil
)))
94 (defmethod ensure-class-using-class :around
((class described-class
) name
&rest args
)
98 (defmethod direct-slot-definition-class ((class described-class
) &rest initargs
)
99 (let ((slot-class (call-next-method)))
100 (make-instance (class-of slot-class
) :direct-superclasses
(list slot-class
(find-class 'described-class-direct-slot-definition
)))))
102 (defclass described-class-direct-slot-definition
()
105 (defmethod shared-initialize :around
((class described-class-direct-slot-definition
) slot-names
&key
&allow-other-keys
)
108 (defmethod validate-superclass
109 ((class described-class
)
110 (superclass standard-class
))
113 (defmethod initialize-instance :after
((class described-class
) &rest initargs
&key
(direct-superclasses '()) direct-slots
)
114 (declare (dynamic-extent initargs
))
115 (finalize-inheritance class
)
116 (ensure-description-for-class class
:direct-slot-specs direct-slots
117 :direct-superclasses direct-superclasses
118 :attributes
(slot-value class
'attributes
)))
120 (defmethod reinitialize-instance :after
((class described-class
) &rest initargs
&key
(direct-superclasses '()) direct-slots
)
121 (declare (dynamic-extent initargs
))
122 (finalize-inheritance class
)
123 (ensure-description-for-class class
:direct-slot-specs direct-slots
124 :direct-superclasses direct-superclasses
125 :attributes
(slot-value class
'attributes
)))
127 (defclass described-standard-class
(described-class standard-class
) ())
129 (defmethod validate-superclass
130 ((class described-standard-class
)
131 (superclass standard-class
))
134 (define-layered-method description-of
((object standard-object
))
135 (or (ignore-errors (find-description (class-name (class-of object
))))
136 (find-description 'standard-object
)))