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-description standard-object
()
18 (class-slots :label
"Slots"
19 :function
(compose 'class-slots
'class-of
)))
20 (:in-description editable
))
22 (define-layered-class slot-definition-attribute
(define-description-attribute)
23 ((slot-name :initarg
:slot-name
24 :accessor attribute-slot-name
28 (define-layered-method attribute-active-p
:around
((attribute slot-definition-attribute
))
29 (let ((active?
(slot-value attribute
'activep
)))
30 (if (and (eq :when active?
)
31 (unbound-slot-value-p (attribute-value attribute
)))
36 (define-layered-method attribute-active-p
37 :in-layer
#.
(defining-description 'editable
)
38 :around
((attribute slot-definition-attribute
))
39 (let ((active?
(slot-value attribute
'activep
)))
40 (if (and (eq :when active?
)
41 (unbound-slot-value-p (attribute-value attribute
)))
45 (defmethod shared-initialize :around
((object slot-definition-attribute
)
47 (with-active-descriptions (editable)
48 (prog1 (call-next-method)
49 (unless (attribute-setter object
)
50 (setf (attribute-setter object
)
52 (if (unbound-slot-value-p v
)
53 (slot-makunbound o
(attribute-slot-name object
))
54 (setf (slot-value o
(attribute-slot-name object
)) v
))))))))
57 (define-layered-method attribute-value-using-object
(object (attribute slot-definition-attribute
))
58 (if (slot-boundp object
(attribute-slot-name attribute
))
60 (slot-value object
(attribute-slot-name attribute
))
63 (defun attribute-slot-makunbound (attribute)
64 (slot-makunbound (attribute-object attribute
) (attribute-slot-name attribute
)))
66 (defun ensure-description-for-class (class &key attributes
(name (intern (format nil
"DESCRIPTION-FOR-~A" (class-name class
))))
67 direct-superclasses direct-slot-specs
)
69 (let* ((super-descriptions
71 (delete nil
(mapcar (rcurry #'find-description nil
)
72 (mapcar #'class-name direct-superclasses
)))))
74 (ensure-layer (defining-description name
)
75 :direct-superclasses
(or super-descriptions
(list (class-of (find-description 'standard-object
))))
78 :for slot in
(class-slots class
)
81 (find (slot-definition-name slot
)
83 :key
(rcurry 'getf
:name
))))
85 (append (alexandria:remove-from-plist direct-spec
92 (getf direct-spec
:attribute-class
)
93 (list :attribute-class
'slot-definition-attribute
))
95 (getf direct-spec
:label
)
96 (list :label
(format nil
97 "~@(~A~)" (substitute #\Space
#\-
(symbol-name (slot-definition-name slot
))))))
98 (list :slot-name
(slot-definition-name slot
)))
99 `(:name
,(slot-definition-name slot
)
100 :attribute-class slot-definition-attribute
101 :slot-name
,(slot-definition-name slot
)
103 "~@(~A~)" (substitute #\Space
#\-
(symbol-name (slot-definition-name slot
)))))))
105 :collect
(slot-definition-name slot
) :into names
106 :finally
(return (cons `(:name active-attributes
107 :value
',(or attributes names
))
109 :metaclass
'define-description-class
)))
110 (unless (ignore-errors (find-description (class-name class
)))
111 (find-layer (ensure-layer (defining-description (class-name class
))
112 :direct-superclasses
(list desc-class
)
113 :metaclass
'define-description-class
)))))
116 (defclass described-class
()
117 ((direct-slot-specs :accessor class-direct-slot-specs
)
118 (attributes :initarg
:attributes
:initform nil
)))
120 (defmethod ensure-class-using-class :around
((class described-class
) name
&rest args
)
124 (defmethod direct-slot-definition-class ((class described-class
) &rest initargs
)
125 (let ((slot-class (call-next-method)))
126 (make-instance (class-of slot-class
) :direct-superclasses
(list slot-class
(find-class 'described-class-direct-slot-definition
)))))
128 (defclass described-class-direct-slot-definition
()
131 (defmethod shared-initialize :around
((class described-class-direct-slot-definition
) slot-names
&key
&allow-other-keys
)
134 (defmethod validate-superclass
135 ((class described-class
)
136 (superclass standard-class
))
139 (defmethod initialize-instance :after
((class described-class
) &rest initargs
&key
(direct-superclasses '()) direct-slots
)
140 (declare (dynamic-extent initargs
))
141 (finalize-inheritance class
)
142 (ensure-description-for-class class
:direct-slot-specs direct-slots
143 :direct-superclasses direct-superclasses
144 :attributes
(slot-value class
'attributes
)))
146 (defmethod reinitialize-instance :after
((class described-class
) &rest initargs
&key
(direct-superclasses '()) direct-slots
)
147 (declare (dynamic-extent initargs
))
148 (finalize-inheritance class
)
149 (ensure-description-for-class class
:direct-slot-specs direct-slots
150 :direct-superclasses direct-superclasses
151 :attributes
(slot-value class
'attributes
)))
153 (defclass described-standard-class
(described-class standard-class
) ())
155 (defmethod validate-superclass
156 ((class described-standard-class
)
157 (superclass standard-class
))
160 (define-layered-method description-of
((object standard-object
))
161 (or (ignore-errors (find-description (class-name (class-of object
))))
162 (find-description 'standard-object
)))