API CHANGE: Removed the OBJECT arg from attribute-value
[clinton/lisp-on-lines.git] / src / attribute.lisp
... / ...
CommitLineData
1(in-package :lisp-on-lines)
2
3(define-layered-class direct-attribute-definition-class
4 (special-layered-direct-slot-definition
5 contextl::singleton-direct-slot-definition)
6 ((attribute-properties
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.")))
11
12(defmethod initialize-instance
13 :after ((attribute direct-attribute-definition-class)
14 &rest initargs)
15 (setf (direct-attribute-properties attribute) initargs))
16
17(define-layered-class effective-attribute-definition-class
18 (special-layered-effective-slot-definition)
19 ((direct-attributes
20 :accessor attribute-direct-attributes)
21 (attribute-object
22 :accessor slot-definition-attribute-object)
23 (attribute-object-initargs
24 :accessor attribute-object-initargs)))
25
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")
29
30(defmacro with-function-access (&body body)
31 "executes body in an environment with *function-access* set to t"
32 `(let ((*function-access* t))
33 ,@body))
34
35(defmacro without-function-access (&body body)
36 "executes body in an environment with *function-access* set to nil"
37 `(let ((*function-access* nil))
38 ,@body))
39
40(define-layered-function property-access-function (description attribute-name property-name)
41 (:method (description attribute-name property-name)
42 (ensure-layered-function
43 (defining-description
44 (intern (format nil "=PROPERTY-ACCESS-FUNCTION-FOR-~A->~A.~A="
45 (description-print-name description)
46 attribute-name
47 property-name)))
48 :lambda-list '(description))))
49
50
51(defvar *init-time-description* nil)
52
53(defmethod attribute-description :around (attribute)
54 (handler-case (call-next-method)
55 (unbound-slot ()
56 (or
57 *init-time-description*
58q (call-next-method)))))
59
60(define-layered-class attribute ()
61 ((description :initarg :description
62 :accessor attribute-description)
63 (name
64 :layered-accessor attribute-name
65 :initarg :name)
66 (effective-attribute-definition
67 :initarg effective-attribute
68 :accessor attribute-effective-attribute-definition)
69 (attribute-class
70 :accessor attribute-class
71 :initarg :attribute-class
72 :initform 'standard-attribute
73 :layered t)
74 (keyword
75 :layered-accessor attribute-keyword
76 :initarg :keyword
77 :initform nil
78 :layered t)
79 (object
80 :layered-accessor attribute-object
81 :accessor described-object
82 :special t)))
83
84
85
86
87(define-layered-class standard-attribute (attribute)
88 ((label
89 :layered-accessor attribute-label
90 :initarg :label
91 :initform nil
92 :layered t
93 :special t)
94 (function
95 :initarg :function
96 :layered-accessor attribute-function
97 :layered t
98 :special t)
99 (value
100 :layered-accessor attribute-value
101 :initarg :value
102 :layered t
103 :special t)
104 (activep
105 :layered-accessor attribute-active-p
106 :initarg :activep ;depreciated
107 :initarg :active
108 :initform t
109 :layered t
110 :special t
111 :documentation
112 "Can be T, NIL or :WHEN. In the latter case, attribute is only active if the attribute value is non-null.")))
113
114
115(define-layered-method attribute-object ((attribute standard-attribute))
116 (if (slot-boundp attribute 'object)
117 (call-next-method)
118 (described-object (attribute-description attribute))))
119
120
121(define-layered-method attribute-value ((attribute standard-attribute))
122 (attribute-value-using-object (attribute-object attribute) attribute))
123
124(define-layered-function attribute-value-using-object (object attribute))
125
126(define-layered-method attribute-value-using-object (object attribute)
127 (let ((fn (handler-case (attribute-function attribute)
128 (unbound-slot () nil))))
129 (if fn
130 (funcall fn object)
131 (slot-value attribute 'value))))
132
133(defun ensure-access-function (class attribute property)
134 (with-function-access
135 (if (slot-definition-specialp property)
136 (let ((slot-symbol
137 (with-symbol-access
138 (slot-value-using-class
139 class attribute property))))
140 (if (fboundp slot-symbol)
141 (symbol-function slot-symbol)
142 (setf (symbol-function slot-symbol)
143 (property-access-function
144 (attribute-description attribute)
145 (attribute-name attribute)
146 (slot-definition-name property)))))
147 (if (slot-boundp-using-class class attribute property)
148 (slot-value-using-class class attribute property)
149 (setf (slot-value-using-class class attribute property)
150 (property-access-function
151 (attribute-description attribute)
152 (attribute-name attribute)
153 (slot-definition-name property)))))))
154
155(define-layered-method slot-boundp-using-layer
156 :in-layer (layer t)
157 :around (class (attribute standard-attribute) property reader)
158
159; (dprint "Checking boundp ~A ~A" (attribute-name attribute)
160 ; (slot-definition-name property))
161
162 (if (or *symbol-access* *function-access*)
163 (call-next-method)
164 (or (when (slot-definition-specialp property)
165 (with-function-access
166 (slot-boundp-using-class class attribute property)))
167 (if (generic-function-methods
168 (ensure-access-function class attribute property))
169 T
170 NIL))))
171
172(define-layered-method (setf slot-value-using-layer)
173 :in-layer (context t)
174 :around
175 (new-value class (attribute standard-attribute) property writer)
176
177;; (dprint "Setting ~A ~A to : ~A" attribute property new-value)
178
179 (if (or *symbol-access* *function-access*)
180 (call-next-method)
181
182 (if (and (slot-definition-specialp property)
183 (with-function-access
184 (without-symbol-access (slot-boundp-using-class class attribute property))))
185 (with-function-access
186 (call-next-method))
187 (let ((layer
188 ;;FIXME: this is wrong for so many reasons
189 (find-layer (first (remove nil (closer-mop::class-precedence-list (class-of context))
190 :key #'class-name))))
191 (boundp (slot-boundp-using-class class attribute property))
192 (fn (ensure-access-function class attribute property)))
193
194 (when (not boundp)
195 ;; * This slot has never been set before.
196 ;; create a method on property-accessor-function
197 ;; so subclasses can see this new property.
198 (ensure-layered-method
199 (layered-function-definer 'property-access-function)
200 `(lambda (description attribute property)
201 (declare (ignore description attribute property))
202 ,fn)
203 :in-layer layer
204 :specializers
205 (list (class-of
206 (attribute-description attribute))
207 (closer-mop:intern-eql-specializer
208 (attribute-name attribute))
209 (closer-mop:intern-eql-specializer
210 (closer-mop:slot-definition-name property)))))
211
212 ;; specialize this property to this description.
213 ;;(dprint "actrually specializering")
214 (ensure-layered-method
215 fn
216 `(lambda (description)
217 (funcall ,(lambda()
218 new-value)))
219 :in-layer layer
220 :specializers (list (class-of (attribute-description attribute))))
221
222 ;; and return the set value as is custom
223 new-value))))
224
225(define-layered-method slot-value-using-layer
226 :in-layer (layer t)
227 :around (class (attribute standard-attribute) property reader)
228
229; ;(dprint "Getting the slot value of ~A" property)
230 (if (or *symbol-access* *function-access*)
231 (call-next-method)
232 (let ((fn (ensure-access-function class attribute property)))
233
234 (unless (slot-boundp-using-class class attribute property)
235 (slot-unbound class attribute (slot-definition-name property)))
236
237 (if (slot-definition-specialp property)
238 (if (with-function-access
239 (slot-boundp-using-class class attribute property))
240 (with-function-access
241 (slot-value-using-class class attribute property))
242 (funcall fn layer (attribute-description attribute)))
243 (funcall fn layer (attribute-description attribute))))))
244
245
246
247
248
249
250(defmethod print-object ((object standard-attribute) stream)
251 (print-unreadable-object (object stream :type nil :identity t)
252 (format stream "ATTRIBUTE ~A" (or (ignore-errors (attribute-name object)) "+unnamed-attribute+"))))
253
254(defgeneric eval-property-initarg (att initarg)
255 (:method ((attribute standard-attribute) initarg)
256 nil)
257 (:method ((attribute standard-attribute) (initarg (eql :function)))
258 t))
259
260(defun prepare-initargs (att args)
261 (loop
262 :for (key arg)
263 :on args :by #'cddr
264 :nconc (list key
265 (if (eval-property-initarg att key)
266 (eval arg)
267 arg))))
268
269
270(defun attribute-value* (attribute)
271 (attribute-value *object* attribute))
272
273(defmacro with-attributes (names description &body body)
274 `(with-slots ,names ,description ,@body))
275
276
277
278
279
280
281
282
283
284
285
286
287