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 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
"~A-~A-~A"
45 (description-print-name description
)
48 :lambda-list
'(description))))
51 (define-layered-class standard-attribute
()
52 ((description-class :initarg description-class
)
54 :layered-accessor attribute-name
56 (effective-attribute-definition
57 :initarg effective-attribute
58 :accessor attribute-effective-attribute-definition
)
60 :accessor attribute-class
61 :initarg
:attribute-class
62 :initform
'standard-attribute
65 :layered-accessor attribute-label
72 :layered-accessor attribute-function
76 :layered-accessor %attribute-value
81 :layered-accessor attribute-active-p
87 :layered-accessor attribute-keyword
93 (defun ensure-access-function (class attribute property
)
95 (if (slot-definition-specialp property
)
98 (slot-value-using-class
99 class attribute property
))))
100 (if (fboundp slot-symbol
)
101 (symbol-function slot-symbol
)
102 (setf (symbol-function slot-symbol
)
103 (property-access-function
104 (attribute-description attribute
)
105 (attribute-name attribute
)
106 (slot-definition-name property
)))))
107 (if (slot-boundp-using-class class attribute property
)
108 (slot-value-using-class class attribute property
)
109 (setf (slot-value-using-class class attribute property
)
110 (property-access-function
111 (attribute-description attribute
)
112 (attribute-name attribute
)
113 (slot-definition-name property
)))))))
115 (define-layered-method slot-boundp-using-layer
117 :around
(class (attribute standard-attribute
) property reader
)
119 ; (dprint "Checking boundp ~A ~A" (attribute-name attribute)
120 ; (slot-definition-name property))
122 (if (or *symbol-access
* *function-access
*)
124 (or (when (slot-definition-specialp property
)
125 (with-function-access
126 (slot-boundp-using-class class attribute property
)))
127 (if (generic-function-methods
128 (ensure-access-function class attribute property
))
132 (define-layered-method (setf slot-value-using-layer
)
133 :in-layer
(context t
)
135 (new-value class
(attribute standard-attribute
) property writer
)
137 ;; (dprint "Setting ~A ~A to : ~A" attribute property new-value)
139 (if (or *symbol-access
* *function-access
*)
142 (if (and (slot-definition-specialp property
)
143 (with-function-access
144 (without-symbol-access (slot-boundp-using-class class attribute property
))))
145 (with-function-access
148 ;;FIXME: this is wrong for so many reasons
149 (find-layer (first (remove nil
(closer-mop::class-precedence-list
(class-of context
))
150 :key
#'class-name
))))
151 (boundp (slot-boundp-using-class class attribute property
))
152 (fn (ensure-access-function class attribute property
)))
155 ;; * This slot has never been set before.
156 ;; create a method on property-accessor-function
157 ;; so subclasses can see this new property.
158 (ensure-layered-method
159 (layered-function-definer 'property-access-function
)
160 `(lambda (description attribute property
)
161 (declare (ignore description attribute property
))
166 (attribute-description attribute
))
167 (closer-mop:intern-eql-specializer
168 (attribute-name attribute
))
169 (closer-mop:intern-eql-specializer
170 (closer-mop:slot-definition-name property
)))))
172 ;; specialize this property to this description.
173 ;;(dprint "actrually specializering")
174 (ensure-layered-method
176 `(lambda (description)
180 :specializers
(list (class-of (attribute-description attribute
))))
182 ;; and return the set value as is custom
185 (define-layered-method slot-value-using-layer
187 :around
(class (attribute standard-attribute
) property reader
)
189 ; ;(dprint "Getting the slot value of ~A" property)
190 (if (or *symbol-access
* *function-access
*)
192 (let ((fn (ensure-access-function class attribute property
)))
194 (unless (slot-boundp-using-class class attribute property
)
195 (slot-unbound class attribute
(slot-definition-name property
)))
197 (if (slot-definition-specialp property
)
198 (if (with-function-access
199 (slot-boundp-using-class class attribute property
))
200 (with-function-access
201 (slot-value-using-class class attribute property
))
202 (funcall fn layer
(attribute-description attribute
)))
203 (funcall fn layer
(attribute-description attribute
))))))
207 (define-layered-function attribute-value
(object attribute
))
209 (define-layered-method attribute-value
(object attribute
)
211 (let ((fn (handler-case (attribute-function attribute
)
212 (unbound-slot () nil
))))
215 (%attribute-value attribute
))))
217 (defmethod attribute-description (attribute)
218 ;(break "description for ~A is (slot-value attribute 'description-name)")
219 (find-layer (slot-value attribute
'description-class
))
220 #+nil
(let ((name (slot-value attribute
'description-name
)))
222 (find-description name
))))
226 (defmethod print-object ((object standard-attribute
) stream
)
227 (print-unreadable-object (object stream
:type nil
:identity t
)
228 (format stream
"ATTRIBUTE ~A" (or (ignore-errors (attribute-name object
)) "+unnamed-attribute+"))))
230 (defgeneric eval-property-initarg
(att initarg
)
231 (:method
((attribute standard-attribute
) initarg
)
233 (:method
((attribute standard-attribute
) (initarg (eql :function
)))
236 (defun prepare-initargs (att args
)
241 (if (eval-property-initarg att key
)
246 (defun attribute-value* (attribute)
247 (attribute-value *object
* attribute
))
249 (defmacro with-attributes
(names description
&body body
)
250 `(with-slots ,names
,description
,@body
))
252 (define-layered-function display-attribute
(object attribute
)
253 (:method
(object attribute
)
254 (display-using-description attribute
*display
* object
)))
256 (define-layered-function display-attribute-label
(object attribute
)
257 (:method
(object attribute
)
258 (format *display
* "~A " (attribute-label attribute
))
261 (define-layered-function display-attribute-value
(object attribute
)
262 (:method
(object attribute
)
263 (let ((val (attribute-value object attribute
)))
265 (format *display
* "~A " val
)
266 (with-active-descriptions (inline)
267 (display *display
* val
)
272 (define-layered-method display-using-description
273 ((attribute standard-attribute
) display object
&rest args
)
274 (declare (ignore args
))
275 (when (attribute-label attribute
)
276 (display-attribute-label object attribute
))
277 (display-attribute-value object attribute
))