1 (in-package :lisp-on-lines
)
3 (define-layered-class direct-attribute-definition-class
4 (special-layered-direct-slot-definition
5 contextl
::singleton-direct-slot-definition
)
7 :accessor direct-attribute-properties
8 :documentation
"This is an plist to hold the values of
9 the attribute's properties as described by this direct
10 attribute definition.")))
12 (defmethod initialize-instance
13 :after
((attribute direct-attribute-definition-class
)
15 (setf (direct-attribute-properties attribute
) initargs
))
17 (define-layered-class effective-attribute-definition-class
18 (special-layered-effective-slot-definition)
20 :accessor attribute-direct-attributes
)
22 :accessor slot-definition-attribute-object
)
23 (attribute-object-initargs
24 :accessor attribute-object-initargs
)))
26 (defvar *function-access
* nil
27 "set/get a place's property function instead of its symbol value
28 when this is set to a non-nil value")
30 (defmacro with-function-access
(&body body
)
31 "executes body in an environment with *function-access* set to t"
32 `(let ((*function-access
* t
))
35 (defmacro without-function-access
(&body body
)
36 "executes body in an environment with *function-access* set to nil"
37 `(let ((*function-access
* nil
))
40 (define-layered-function property-access-function
(description attribute-name property-name
)
41 (:method
(description attribute-name property-name
)
42 (ensure-layered-function
44 (intern (format nil
"=PROPERTY-ACCESS-FUNCTION-FOR-~A->~A.~A="
45 (description-print-name description
)
48 :lambda-list
'(description))))
51 (defvar *init-time-description
* nil
)
53 (defmethod attribute-description :around
(attribute)
54 (handler-case (call-next-method)
57 *init-time-description
*
58 (call-next-method)))))
60 (define-layered-class attribute
()
61 ((description :initarg
:description
62 :accessor attribute-description
)
64 :layered-accessor attribute-name
66 (effective-attribute-definition
67 :initarg effective-attribute
68 :accessor attribute-effective-attribute-definition
)
70 :accessor attribute-class
71 :initarg
:attribute-class
72 :initform
'standard-attribute
)
74 :layered-accessor attribute-keyword
79 :layered-accessor attribute-object
80 :accessor described-object
84 (define-layered-class standard-attribute
(attribute)
86 :layered-accessor attribute-label
92 :layered-accessor attribute-label-formatter
93 :initarg
:label-formatter
99 :layered-accessor attribute-function
103 :layered-accessor attribute-value
108 :layered-accessor attribute-value-formatter
109 :initarg
:value-formatter
114 :layered-accessor attribute-active-p
115 :initarg
:activep
;depreciated
121 "Can be T, NIL or :WHEN. In the latter case, attribute is only active if the attribute value is non-null.")
122 (active-attributes :layered-accessor attribute-active-attributes
126 (active-descriptions :layered-accessor attribute-active-descriptions
131 (inactive-descriptions :layered-accessor attribute-inactive-descriptions
137 (define-layered-method attribute-active-p
:around
(attribute)
138 (let ((active?
(call-next-method)))
139 (if (eq :when active?
)
140 (not (null (attribute-value attribute
)))
143 (define-layered-method attribute-label-formatter
:around
(attribute)
144 (or (slot-value attribute
'label-formatter
)
145 (attribute-value (find-attribute (attribute-description attribute
) 'label-formatter
))
146 (error "No Formatter .. fool!")))
148 (define-layered-method attribute-value-formatter
:around
(attribute)
150 (or (slot-value attribute
'value-formatter
)
151 (attribute-value (find-attribute (attribute-description attribute
) 'value-formatter
))
152 (error "No Formatter .. fool!")))
156 (define-layered-method attribute-object
((attribute standard-attribute
))
157 (if (slot-boundp attribute
'object
)
159 (described-object (attribute-description attribute
))))
162 (define-layered-function attribute-value-using-object
(object attribute
))
163 (define-layered-function (setf attribute-value-using-object
) (value object attribute
))
165 (define-layered-method attribute-value
((attribute standard-attribute
))
166 (attribute-value-using-object (attribute-object attribute
) attribute
))
168 (define-layered-method attribute-value-using-object
(object attribute
)
169 (let ((fn (handler-case (attribute-function attribute
)
170 (unbound-slot () nil
))))
173 (slot-value attribute
'value
))))
175 (define-layered-method (setf attribute-value
) (value (attribute standard-attribute
))
176 (setf (attribute-value-using-object (attribute-object attribute
) attribute
) value
))
178 (define-layered-method (setf attribute-value-using-object
) (value object attribute
)
179 (error "No (SETF ATTRIBUTE-VALUE-USING-OBJECT) for ~A ~A and we are not editable"
183 (defun ensure-access-function (class attribute property
)
184 (with-function-access
185 (if (slot-definition-specialp property
)
188 (slot-value-using-class
189 class attribute property
))))
190 (if (fboundp slot-symbol
)
191 (symbol-function slot-symbol
)
192 (setf (symbol-function slot-symbol
)
193 (property-access-function
194 (attribute-description attribute
)
195 (attribute-name attribute
)
196 (slot-definition-name property
)))))
197 (if (slot-boundp-using-class class attribute property
)
198 (slot-value-using-class class attribute property
)
199 (setf (slot-value-using-class class attribute property
)
200 (property-access-function
201 (attribute-description attribute
)
202 (attribute-name attribute
)
203 (slot-definition-name property
)))))))
205 (define-layered-method slot-boundp-using-layer
207 :around
(class (attribute standard-attribute
) property reader
)
209 ; (dprint "Checking boundp ~A ~A" (attribute-name attribute)
210 ; (slot-definition-name property))
212 (if (or *symbol-access
* *function-access
*)
214 (or (when (slot-definition-specialp property
)
215 (with-function-access
216 (slot-boundp-using-class class attribute property
)))
217 (if (generic-function-methods
218 (ensure-access-function class attribute property
))
222 (define-layered-method (setf slot-value-using-layer
)
223 :in-layer
(context t
)
225 (new-value class
(attribute standard-attribute
) property writer
)
227 ;; (dprint "Setting ~A ~A to : ~A" attribute property new-value)
229 (if (or *symbol-access
* *function-access
*)
232 (if (and (slot-definition-specialp property
)
233 (with-function-access
234 (without-symbol-access (slot-boundp-using-class class attribute property
))))
235 (with-function-access
238 ;;FIXME: this is wrong for so many reasons
239 (find-layer (first (remove nil
(closer-mop::class-precedence-list
(class-of context
))
240 :key
#'class-name
))))
241 (boundp (slot-boundp-using-class class attribute property
))
242 (fn (ensure-access-function class attribute property
)))
245 ;; * This slot has never been set before.
246 ;; create a method on property-accessor-function
247 ;; so subclasses can see this new property.
248 (ensure-layered-method
249 (layered-function-definer 'property-access-function
)
250 `(lambda (description attribute property
)
251 (declare (ignore description attribute property
))
256 (attribute-description attribute
))
257 (closer-mop:intern-eql-specializer
258 (attribute-name attribute
))
259 (closer-mop:intern-eql-specializer
260 (closer-mop:slot-definition-name property
)))))
262 ;; specialize this property to this description.
263 ;;(dprint "actrually specializering")
264 (ensure-layered-method
266 `(lambda (description)
270 :specializers
(list (class-of (attribute-description attribute
))))
272 ;; and return the set value as is custom
275 (define-layered-method slot-value-using-layer
277 :around
(class (attribute standard-attribute
) property reader
)
279 ; ;(dprint "Getting the slot value of ~A" property)
280 (if (or *symbol-access
* *function-access
*)
282 (let ((fn (ensure-access-function class attribute property
)))
284 (unless (slot-boundp-using-class class attribute property
)
285 (slot-unbound class attribute
(slot-definition-name property
)))
287 (if (slot-definition-specialp property
)
288 (if (with-function-access
289 (slot-boundp-using-class class attribute property
))
290 (with-function-access
291 (slot-value-using-class class attribute property
))
292 (funcall fn layer
(attribute-description attribute
)))
293 (handler-case (funcall fn layer
(attribute-description attribute
))
295 (warn "Error calling ~A" fn
)))))))
302 (defmethod print-object ((object standard-attribute
) stream
)
303 (print-unreadable-object (object stream
:type nil
:identity t
)
304 (format stream
"ATTRIBUTE ~A" (or (ignore-errors (attribute-name object
)) "+unnamed-attribute+"))))
306 (defgeneric eval-property-initarg
(att initarg
)
307 (:method
((attribute standard-attribute
) initarg
)
309 (:method
((attribute standard-attribute
) (initarg (eql :function
)))
311 (:method
((attribute standard-attribute
) (initarg (eql :value
)))
314 (defun prepare-initargs (att args
)
319 (if (eval-property-initarg att key
)
324 (defun attribute-value* (attribute)
325 (attribute-value *object
* attribute
))
327 (defmacro with-attributes
(names description
&body body
)
328 `(let ,(loop for name in names collect
329 (list name
`(find-attribute ,description
',name
)))