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 (setf (slot-value o
(attribute-slot-name object
)) v
)))))))
55 (define-layered-method attribute-value-using-object
(object (attribute slot-definition-attribute
))
56 (if (slot-boundp object
(attribute-slot-name attribute
))
58 (slot-value object
(attribute-slot-name attribute
))
61 (defun attribute-slot-makunbound (attribute)
62 (slot-makunbound (attribute-object attribute
) (attribute-slot-name attribute
)))
64 (defun ensure-description-for-class (class &key attributes
(name (intern (format nil
"DESCRIPTION-FOR-~A" (class-name class
))))
65 direct-superclasses direct-slot-specs
)
67 (let* ((super-descriptions
69 (delete nil
(mapcar (rcurry #'find-description nil
)
70 (mapcar #'class-name direct-superclasses
)))))
72 (ensure-layer (defining-description name
)
73 :direct-superclasses
(or super-descriptions
(list (class-of (find-description 'standard-object
))))
76 :for slot in
(class-slots class
)
79 (find (slot-definition-name slot
)
81 :key
(rcurry 'getf
:name
))))
83 (append (alexandria:remove-from-plist direct-spec
90 (getf direct-spec
:attribute-class
)
91 (list :attribute-class
'slot-definition-attribute
))
93 (getf direct-spec
:label
)
94 (list :label
(format nil
95 "~@(~A~)" (substitute #\Space
#\-
(symbol-name (slot-definition-name slot
))))))
96 (list :slot-name
(slot-definition-name slot
)))
97 `(:name
,(slot-definition-name slot
)
98 :attribute-class slot-definition-attribute
99 :slot-name
,(slot-definition-name slot
)
101 "~@(~A~)" (substitute #\Space
#\-
(symbol-name (slot-definition-name slot
)))))))
103 :collect
(slot-definition-name slot
) :into names
104 :finally
(return (cons `(:name active-attributes
105 :value
',(or attributes names
))
107 :metaclass
'define-description-class
)))
108 (unless (ignore-errors (find-description (class-name class
)))
109 (find-layer (ensure-layer (defining-description (class-name class
))
110 :direct-superclasses
(list desc-class
)
111 :metaclass
'define-description-class
)))))
114 (defclass described-class
()
115 ((direct-slot-specs :accessor class-direct-slot-specs
)
116 (attributes :initarg
:attributes
:initform nil
)))
118 (defmethod ensure-class-using-class :around
((class described-class
) name
&rest args
)
122 (defmethod direct-slot-definition-class ((class described-class
) &rest initargs
)
123 (let ((slot-class (call-next-method)))
124 (make-instance (class-of slot-class
) :direct-superclasses
(list slot-class
(find-class 'described-class-direct-slot-definition
)))))
126 (defclass described-class-direct-slot-definition
()
129 (defmethod shared-initialize :around
((class described-class-direct-slot-definition
) slot-names
&key
&allow-other-keys
)
132 (defmethod validate-superclass
133 ((class described-class
)
134 (superclass standard-class
))
137 (defmethod initialize-instance :after
((class described-class
) &rest initargs
&key
(direct-superclasses '()) direct-slots
)
138 (declare (dynamic-extent initargs
))
139 (finalize-inheritance class
)
140 (ensure-description-for-class class
:direct-slot-specs direct-slots
141 :direct-superclasses direct-superclasses
142 :attributes
(slot-value class
'attributes
)))
144 (defmethod reinitialize-instance :after
((class described-class
) &rest initargs
&key
(direct-superclasses '()) direct-slots
)
145 (declare (dynamic-extent initargs
))
146 (finalize-inheritance class
)
147 (ensure-description-for-class class
:direct-slot-specs direct-slots
148 :direct-superclasses direct-superclasses
149 :attributes
(slot-value class
'attributes
)))
151 (defclass described-standard-class
(described-class standard-class
) ())
153 (defmethod validate-superclass
154 ((class described-standard-class
)
155 (superclass standard-class
))
158 (define-layered-method description-of
((object standard-object
))
159 (or (ignore-errors (find-description (class-name (class-of object
))))
160 (find-description 'standard-object
)))