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
22 (define-layered-method attribute-active-p
:around
((attribute slot-definition-attribute
))
23 (let ((active?
(slot-value attribute
'activep
)))
24 (if (and (eq :when active?
)
25 (unbound-slot-value-p (attribute-value attribute
)))
30 (define-layered-method attribute-active-p
31 :in-layer
#.
(defining-description 'editable
)
32 :around
((attribute slot-definition-attribute
))
33 (let ((active?
(slot-value attribute
'activep
)))
34 (if (and (eq :when active?
)
35 (unbound-slot-value-p (attribute-value attribute
)))
39 (defmethod shared-initialize :around
((object slot-definition-attribute
)
41 (prog1 (call-next-method)
42 (unless (attribute-setter object
)
43 (setf (attribute-setter object
)
45 (setf (slot-value o
(attribute-slot-name object
)) v
))))))
48 (define-layered-method attribute-value-using-object
(object (attribute slot-definition-attribute
))
49 (if (slot-boundp object
(attribute-slot-name attribute
))
51 (slot-value object
(attribute-slot-name attribute
))
54 (defun attribute-slot-makunbound (attribute)
55 (slot-makunbound (attribute-object attribute
) (attribute-slot-name attribute
)))
57 (defun ensure-description-for-class (class &key attributes
(name (intern (format nil
"DESCRIPTION-FOR-~A" (class-name class
))))
58 direct-superclasses direct-slot-specs
)
60 (let* ((super-descriptions
62 (delete nil
(mapcar (rcurry #'find-description nil
)
63 (mapcar #'class-name direct-superclasses
)))))
65 (ensure-class (defining-description name
)
66 :direct-superclasses
(or super-descriptions
(list (class-of (find-description 'standard-object
))))
69 :for slot in
(class-slots class
)
72 (find (slot-definition-name slot
)
74 :key
(rcurry 'getf
:name
))))
76 (append (alexandria:remove-from-plist direct-spec
83 (getf direct-spec
:attribute-class
)
84 (list :attribute-class
'slot-definition-attribute
))
86 (getf direct-spec
:label
)
87 (list :label
(format nil
88 "~@(~A~)" (substitute #\Space
#\-
(symbol-name (slot-definition-name slot
))))))
89 (list :slot-name
(slot-definition-name slot
)))
90 `(:name
,(slot-definition-name slot
)
91 :attribute-class slot-definition-attribute
92 :slot-name
,(slot-definition-name slot
)
94 "~@(~A~)" (substitute #\Space
#\-
(symbol-name (slot-definition-name slot
)))))))
96 :collect
(slot-definition-name slot
) :into names
97 :finally
(return (cons `(:name active-attributes
98 :value
',(or attributes names
))
100 :metaclass
'standard-description-class
)))
101 (unless (ignore-errors (find-description (class-name class
)))
102 (ensure-class (defining-description (class-name class
))
103 :direct-superclasses
(list desc-class
)
104 :metaclass
'standard-description-class
))
105 (find-description name
)))
108 (defclass described-class
()
109 ((direct-slot-specs :accessor class-direct-slot-specs
)
110 (attributes :initarg
:attributes
:initform nil
)))
112 (defmethod ensure-class-using-class :around
((class described-class
) name
&rest args
)
116 (defmethod direct-slot-definition-class ((class described-class
) &rest initargs
)
117 (let ((slot-class (call-next-method)))
118 (make-instance (class-of slot-class
) :direct-superclasses
(list slot-class
(find-class 'described-class-direct-slot-definition
)))))
120 (defclass described-class-direct-slot-definition
()
123 (defmethod shared-initialize :around
((class described-class-direct-slot-definition
) slot-names
&key
&allow-other-keys
)
126 (defmethod validate-superclass
127 ((class described-class
)
128 (superclass standard-class
))
131 (defmethod initialize-instance :after
((class described-class
) &rest initargs
&key
(direct-superclasses '()) direct-slots
)
132 (declare (dynamic-extent initargs
))
133 (finalize-inheritance class
)
134 (ensure-description-for-class class
:direct-slot-specs direct-slots
135 :direct-superclasses direct-superclasses
136 :attributes
(slot-value class
'attributes
)))
138 (defmethod reinitialize-instance :after
((class described-class
) &rest initargs
&key
(direct-superclasses '()) direct-slots
)
139 (declare (dynamic-extent initargs
))
140 (finalize-inheritance class
)
141 (ensure-description-for-class class
:direct-slot-specs direct-slots
142 :direct-superclasses direct-superclasses
143 :attributes
(slot-value class
'attributes
)))
145 (defclass described-standard-class
(described-class standard-class
) ())
147 (defmethod validate-superclass
148 ((class described-standard-class
)
149 (superclass standard-class
))
152 (define-layered-method description-of
((object standard-object
))
153 (or (ignore-errors (find-description (class-name (class-of object
))))
154 (find-description 'standard-object
)))