bd691e21 |
1 | ;; Common Lisp bindings for GTK+ v2.x |
2 | ;; Copyright 2000-2006 Espen S. Johnsen <espen@users.sf.net> |
3 | ;; |
4 | ;; Permission is hereby granted, free of charge, to any person obtaining |
5 | ;; a copy of this software and associated documentation files (the |
6 | ;; "Software"), to deal in the Software without restriction, including |
7 | ;; without limitation the rights to use, copy, modify, merge, publish, |
8 | ;; distribute, sublicense, and/or sell copies of the Software, and to |
9 | ;; permit persons to whom the Software is furnished to do so, subject to |
10 | ;; the following conditions: |
11 | ;; |
12 | ;; The above copyright notice and this permission notice shall be |
13 | ;; included in all copies or substantial portions of the Software. |
14 | ;; |
15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, |
16 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF |
17 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. |
18 | ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY |
19 | ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, |
20 | ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE |
21 | ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. |
22 | |
f387e463 |
23 | ;; $Id: virtual-slots.lisp,v 1.9 2007/06/15 12:23:39 espen Exp $ |
bd691e21 |
24 | |
25 | (in-package "GFFI") |
26 | |
27 | ;;;; Superclass for all metaclasses implementing some sort of virtual slots |
28 | |
6b716036 |
29 | (defclass virtual-slots-class (standard-class) |
30 | ()) |
31 | |
32 | (defclass direct-virtual-slot-definition (standard-direct-slot-definition) |
33 | ((setter :reader slot-definition-setter :initarg :setter) |
34 | (getter :reader slot-definition-getter :initarg :getter) |
35 | (unbound :reader slot-definition-unbound :initarg :unbound) |
36 | (boundp :reader slot-definition-boundp :initarg :boundp) |
37 | (makunbound :reader slot-definition-makunbound :initarg :makunbound) |
38 | #+clisp(type :initarg :type :reader slot-definition-type))) |
bd691e21 |
39 | |
6b716036 |
40 | (defclass effective-virtual-slot-definition (standard-effective-slot-definition) |
41 | ((setter :reader slot-definition-setter :initarg :setter) |
42 | (getter :reader slot-definition-getter :initarg :getter) |
43 | (unbound :reader slot-definition-unbound :initarg :unbound) |
44 | (boundp :reader slot-definition-boundp :initarg :boundp) |
45 | (makunbound :reader slot-definition-makunbound :initarg :makunbound) |
46 | #+clisp(reader-function) |
47 | #+clisp(writer-function) |
48 | #+clisp(boundp-function) |
49 | makunbound-function |
50 | #+clisp(type :initarg :type :reader slot-definition-type))) |
51 | |
52 | (defclass direct-special-slot-definition (standard-direct-slot-definition) |
53 | ((special :initarg :special :accessor slot-definition-special))) |
54 | |
55 | (defclass effective-special-slot-definition (standard-effective-slot-definition) |
56 | ((special :initarg :special :accessor slot-definition-special))) |
57 | |
58 | (defclass virtual-slots-object (standard-object) |
59 | ()) |
60 | |
376809b0 |
61 | (defgeneric slot-readable-p (slotd)) |
62 | (defgeneric slot-writable-p (slotd)) |
6b716036 |
63 | (defgeneric compute-slot-reader-function (slotd &optional signal-unbound-p)) |
bd691e21 |
64 | (defgeneric compute-slot-boundp-function (slotd)) |
65 | (defgeneric compute-slot-writer-function (slotd)) |
66 | (defgeneric compute-slot-makunbound-function (slotd)) |
67 | |
376809b0 |
68 | (defmethod slot-readable-p ((slotd standard-effective-slot-definition)) |
69 | (declare (ignore slotd)) |
70 | t) |
71 | |
72 | (defmethod slot-writable-p ((slotd standard-effective-slot-definition)) |
73 | (declare (ignore slotd)) |
74 | t) |
75 | |
bd691e21 |
76 | |
77 | #+clisp |
78 | (defmethod slot-definition-type ((slotd t)) |
79 | (clos:slot-definition-type slotd)) |
80 | |
81 | |
82 | (defmethod direct-slot-definition-class ((class virtual-slots-class) &rest initargs) |
83 | (cond |
84 | ((eq (getf initargs :allocation) :virtual) |
85 | (find-class 'direct-virtual-slot-definition)) |
86 | ((getf initargs :special) |
87 | (find-class 'direct-special-slot-definition)) |
88 | (t (call-next-method)))) |
89 | |
90 | (defmethod effective-slot-definition-class ((class virtual-slots-class) &rest initargs) |
91 | (cond |
92 | ((eq (getf initargs :allocation) :virtual) |
93 | (find-class 'effective-virtual-slot-definition)) |
94 | ((getf initargs :special) |
95 | (find-class 'effective-special-slot-definition)) |
96 | (t (call-next-method)))) |
97 | |
98 | |
376809b0 |
99 | (defmethod slot-readable-p ((slotd effective-virtual-slot-definition)) |
100 | (slot-boundp slotd 'getter)) |
101 | |
bd691e21 |
102 | (define-condition unreadable-slot (cell-error) |
103 | ((instance :reader unreadable-slot-instance :initarg :instance)) |
104 | (:report (lambda (condition stream) |
105 | (format stream "~@<The slot ~S in the object ~S is not readable.~@:>" |
106 | (cell-error-name condition) |
107 | (unreadable-slot-instance condition))))) |
108 | |
6b716036 |
109 | (defmethod compute-slot-reader-function :around ((slotd effective-virtual-slot-definition) &optional (signal-unbound-p t)) |
376809b0 |
110 | (if (not (slot-readable-p slotd)) |
111 | #'(lambda (object) |
112 | (error 'unreadable-slot :name (slot-definition-name slotd) :instance object)) |
113 | (let ((reader-function (call-next-method))) |
114 | (cond |
9b773fc8 |
115 | ;; Don't create wrapper to signal unbound value |
376809b0 |
116 | ((not signal-unbound-p) reader-function) |
117 | |
118 | ;; An explicit boundp function has been supplied |
119 | ((slot-boundp slotd 'boundp) |
b7750702 |
120 | (let ((boundp (slot-value slotd 'boundp))) |
376809b0 |
121 | #'(lambda (object) |
b7750702 |
122 | (if (not (funcall boundp object)) |
123 | (slot-unbound (class-of object) object (slot-definition-name slotd)) |
124 | (funcall reader-function object))))) |
376809b0 |
125 | |
126 | ;; A type unbound value exists |
127 | ((let ((unbound-method (find-applicable-type-method 'unbound-value |
128 | (slot-definition-type slotd) nil))) |
129 | (when unbound-method |
130 | (let ((unbound-value (funcall unbound-method (slot-definition-type slotd)))) |
131 | #'(lambda (object) |
132 | (let ((value (funcall reader-function object))) |
133 | (if (eq value unbound-value) |
134 | (slot-unbound (class-of object) object (slot-definition-name slotd)) |
135 | value))))))) |
136 | |
137 | ((let ((boundp-function (compute-slot-boundp-function slotd))) |
138 | #'(lambda (object) |
139 | (if (funcall boundp-function object) |
140 | (funcall reader-function object) |
141 | (slot-unbound (class-of object) object (slot-definition-name slotd)))))))))) |
6b716036 |
142 | |
143 | (defmethod compute-slot-reader-function ((slotd effective-virtual-slot-definition) &optional signal-unbound-p) |
144 | (declare (ignore signal-unbound-p)) |
553aa0e3 |
145 | (let ((getter (slot-value slotd 'getter))) |
146 | #-sbcl getter |
147 | #+sbcl |
148 | (etypecase getter |
149 | (symbol #'(lambda (object) (funcall getter object))) |
150 | (function getter)))) |
bd691e21 |
151 | |
152 | (defmethod compute-slot-boundp-function ((slotd effective-virtual-slot-definition)) |
153 | (cond |
376809b0 |
154 | ;; Non readable slots are not bound per definition |
155 | ((not (slot-readable-p slotd)) |
156 | #'(lambda (object) (declare (ignore object)) nil)) |
157 | |
bd691e21 |
158 | ;; An explicit boundp function has been supplied |
553aa0e3 |
159 | ((slot-boundp slotd 'boundp) |
160 | (let ((boundp (slot-value slotd 'boundp))) |
161 | #-sbcl boundp |
162 | #+sbcl |
163 | (etypecase boundp |
164 | (symbol #'(lambda (object) (funcall boundp object))) |
165 | (function boundp)))) |
166 | |
bd691e21 |
167 | ;; An unbound value has been supplied |
168 | ((slot-boundp slotd 'unbound) |
6b716036 |
169 | (let ((reader-function (compute-slot-reader-function slotd nil)) |
bd691e21 |
170 | (unbound-value (slot-value slotd 'unbound))) |
171 | #'(lambda (object) |
172 | (not (eql (funcall reader-function object) unbound-value))))) |
173 | |
174 | ;; A type unbound value exists |
175 | ((let ((unbound-method (find-applicable-type-method 'unbound-value |
176 | (slot-definition-type slotd) nil))) |
177 | (when unbound-method |
6b716036 |
178 | (let ((reader-function (compute-slot-reader-function slotd nil)) |
bd691e21 |
179 | (unbound-value (funcall unbound-method (slot-definition-type slotd)))) |
180 | #'(lambda (object) |
181 | (not (eql (funcall reader-function object) unbound-value))))))) |
182 | |
183 | ;; Slot has no unbound state |
184 | (#'(lambda (object) (declare (ignore object)) t)))) |
185 | |
376809b0 |
186 | (defmethod slot-writable-p ((slotd effective-virtual-slot-definition)) |
187 | (slot-boundp slotd 'setter)) |
188 | |
bd691e21 |
189 | (define-condition unwritable-slot (cell-error) |
190 | ((instance :reader unwritable-slot-instance :initarg :instance)) |
191 | (:report (lambda (condition stream) |
192 | (format stream "~@<The slot ~S in the object ~S is not writable.~@:>" |
193 | (cell-error-name condition) |
194 | (unwritable-slot-instance condition))))) |
195 | |
376809b0 |
196 | (defmethod compute-slot-writer-function :around ((slotd effective-virtual-slot-definition)) |
197 | (if (not (slot-writable-p slotd)) |
198 | #'(lambda (value object) |
199 | (declare (ignore value)) |
200 | (error 'unwritable-slot :name (slot-definition-name slotd) :instance object)) |
201 | (call-next-method))) |
202 | |
bd691e21 |
203 | (defmethod compute-slot-writer-function ((slotd effective-virtual-slot-definition)) |
553aa0e3 |
204 | (let ((setter (slot-value slotd 'setter))) |
205 | #-sbcl setter |
206 | #+sbcl |
207 | (etypecase setter |
208 | (symbol #'(lambda (object value) (funcall setter object value))) |
e0ba6229 |
209 | (list #'(lambda (object value) |
f387e463 |
210 | ;; Setter is a (setf ...) form and thus takes the |
211 | ;; value as the first argument |
e0ba6229 |
212 | (funcall setter value object))) |
553aa0e3 |
213 | (function setter)))) |
376809b0 |
214 | |
215 | (define-condition slot-can-not-be-unbound (cell-error) |
216 | ((instance :reader slot-can-not-be-unbound-instance :initarg :instance)) |
217 | (:report (lambda (condition stream) |
218 | (format stream "~@<The slot ~S in the object ~S can not be made unbound.~@:>" |
219 | (cell-error-name condition) |
220 | (slot-can-not-be-unbound-instance condition))))) |
bd691e21 |
221 | |
222 | (defmethod compute-slot-makunbound-function ((slotd effective-virtual-slot-definition)) |
223 | (cond |
376809b0 |
224 | ((not (slot-writable-p slotd)) |
225 | #'(lambda (object) |
226 | (error 'unwritable-slot :name (slot-definition-name slotd) :instance object))) |
553aa0e3 |
227 | ((slot-boundp slotd 'makunbound) |
228 | (let ((makunbound (slot-value slotd 'makunbound))) |
229 | #-sbcl makunbound |
230 | #+sbcl |
231 | (etypecase makunbound |
232 | (symbol #'(lambda (object) (funcall makunbound object))) |
233 | (function makunbound)))) |
bd691e21 |
234 | ((slot-boundp slotd 'unbound) |
235 | #'(lambda (object) |
236 | (funcall (slot-value slotd 'writer-function) (slot-value slotd 'unbound) object))) |
237 | (t |
238 | #'(lambda (object) |
376809b0 |
239 | (error 'slot-can-not-be-unbound :name (slot-definition-name slotd) :instance object))))) |
bd691e21 |
240 | |
241 | |
242 | #-clisp |
243 | (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition)) |
6b716036 |
244 | #?-(sbcl>= 0 9 15) ; Delayed to avoid recursive call of finalize-inheritanze |
bd691e21 |
245 | (setf |
246 | (slot-value slotd 'reader-function) (compute-slot-reader-function slotd) |
247 | (slot-value slotd 'boundp-function) (compute-slot-boundp-function slotd) |
248 | (slot-value slotd 'writer-function) (compute-slot-writer-function slotd) |
249 | (slot-value slotd 'makunbound-function) (compute-slot-makunbound-function slotd)) |
250 | |
251 | #?-(sbcl>= 0 9 8)(initialize-internal-slot-gfs (slot-definition-name slotd))) |
252 | |
253 | |
254 | #-clisp |
255 | (defmethod compute-slot-accessor-info ((slotd effective-virtual-slot-definition) type gf) |
256 | nil) |
257 | |
6b716036 |
258 | |
bd691e21 |
259 | (defun slot-bound-in-some-p (instances slot) |
260 | (find-if |
261 | #'(lambda (ob) |
262 | (and (slot-exists-p ob slot) (slot-boundp ob slot))) |
263 | instances)) |
264 | |
265 | (defun most-specific-slot-value (instances slot &optional default) |
266 | (let ((object (slot-bound-in-some-p instances slot))) |
267 | (if object |
268 | (slot-value object slot) |
269 | default))) |
270 | |
271 | (defun compute-most-specific-initargs (slotds slots) |
272 | (loop |
273 | for slot in slots |
274 | as (slot-name initarg) = (if (atom slot) |
275 | (list slot (intern (string slot) "KEYWORD")) |
276 | slot) |
277 | when (slot-bound-in-some-p slotds slot-name) |
278 | nconc (list initarg (most-specific-slot-value slotds slot-name)))) |
279 | |
280 | (defmethod compute-effective-slot-definition-initargs ((class virtual-slots-class) direct-slotds) |
281 | (typecase (first direct-slotds) |
282 | (direct-virtual-slot-definition |
283 | (nconc |
284 | (compute-most-specific-initargs direct-slotds |
285 | '(getter setter unbound boundp makunbound |
286 | #?(or (sbcl>= 0 9 8) (featurep :clisp)) |
287 | (#?-(sbcl>= 0 9 10)type #?(sbcl>= 0 9 10)sb-pcl::%type :type))) |
288 | (call-next-method))) |
289 | (direct-special-slot-definition |
290 | (append '(:special t) (call-next-method))) |
291 | (t (call-next-method)))) |
292 | |
6b716036 |
293 | #?(or (not (sbcl>= 0 9 14)) (featurep :clisp)) |
bd691e21 |
294 | (defmethod slot-value-using-class |
6b716036 |
295 | ((class virtual-slots-class) (object virtual-slots-object) |
bd691e21 |
296 | (slotd effective-virtual-slot-definition)) |
6b716036 |
297 | (funcall (slot-value slotd 'reader-function) object)) |
bd691e21 |
298 | |
6b716036 |
299 | #?(or (not (sbcl>= 0 9 14)) (featurep :clisp)) |
bd691e21 |
300 | (defmethod slot-boundp-using-class |
6b716036 |
301 | ((class virtual-slots-class) (object virtual-slots-object) |
bd691e21 |
302 | (slotd effective-virtual-slot-definition)) |
6b716036 |
303 | (funcall (slot-value slotd 'boundp-function) object)) |
bd691e21 |
304 | |
6b716036 |
305 | #?(or (not (sbcl>= 0 9 14)) (featurep :clisp)) |
bd691e21 |
306 | (defmethod (setf slot-value-using-class) |
6b716036 |
307 | (value (class virtual-slots-class) (object virtual-slots-object) |
bd691e21 |
308 | (slotd effective-virtual-slot-definition)) |
309 | (funcall (slot-value slotd 'writer-function) value object)) |
310 | |
311 | (defmethod slot-makunbound-using-class |
6b716036 |
312 | ((class virtual-slots-class) (object virtual-slots-object) |
bd691e21 |
313 | (slotd effective-virtual-slot-definition)) |
314 | (funcall (slot-value slotd 'makunbound-function) object)) |
315 | |
316 | |
6b716036 |
317 | ;; In CLISP and SBCL (0.9.15 or newler) a class may not have been |
318 | ;; finalized when update-slots are called. So to avoid the possibility |
9b773fc8 |
319 | ;; of finalize-instance being called recursivly we have to delay the |
6b716036 |
320 | ;; initialization of slot functions until after an instance has been |
321 | ;; created. |
322 | #?(or (sbcl>= 0 9 15) (featurep :clisp)) |
323 | (defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'reader-function))) |
893a3d7f |
324 | (declare (ignore class)) |
6b716036 |
325 | (setf (slot-value slotd name) (compute-slot-reader-function slotd))) |
bd691e21 |
326 | |
6b716036 |
327 | #?(or (sbcl>= 0 9 15) (featurep :clisp)) |
328 | (defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'boundp-function))) |
893a3d7f |
329 | (declare (ignore class)) |
6b716036 |
330 | (setf (slot-value slotd name) (compute-slot-boundp-function slotd))) |
331 | |
332 | #?(or (sbcl>= 0 9 15) (featurep :clisp)) |
333 | (defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'writer-function))) |
893a3d7f |
334 | (declare (ignore class)) |
6b716036 |
335 | (setf (slot-value slotd name) (compute-slot-writer-function slotd))) |
336 | |
337 | #?(or (sbcl>= 0 9 15) (featurep :clisp)) |
338 | (defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'makunbound-function))) |
893a3d7f |
339 | (declare (ignore class)) |
6b716036 |
340 | (setf (slot-value slotd name) (compute-slot-makunbound-function slotd))) |
bd691e21 |
341 | |
bd691e21 |
342 | |
343 | (defmethod validate-superclass |
344 | ((class virtual-slots-class) (super standard-class)) |
345 | t) |
346 | |
347 | (defmethod slot-definition-special ((slotd standard-direct-slot-definition)) |
348 | (declare (ignore slotd)) |
349 | nil) |
350 | |
351 | (defmethod slot-definition-special ((slotd standard-effective-slot-definition)) |
352 | (declare (ignore slotd)) |
353 | nil) |
354 | |
355 | |
bd691e21 |
356 | ;;; To determine if a slot should be initialized with the initform, |
357 | ;;; CLISP checks whether it is unbound or not. This doesn't work with |
9b773fc8 |
358 | ;;; virtual slots that does not have an unbound state, so we have to |
bd691e21 |
359 | ;;; implement initform initialization in a way similar to how it is |
360 | ;;; done in PCL. |
361 | #+clisp |
362 | (defmethod shared-initialize ((object virtual-slots-object) names &rest initargs) |
363 | (let* ((class (class-of object)) |
364 | (slotds (class-slots class)) |
365 | (keywords (loop |
366 | for args on initargs by #'cddr |
367 | collect (first args))) |
368 | (names |
369 | (loop |
370 | for slotd in slotds |
371 | as name = (slot-definition-name slotd) |
372 | as initargs = (slot-definition-initargs slotd) |
373 | as init-p = (and |
374 | (or (eq names t) (find name names)) |
375 | (slot-definition-initfunction slotd) |
376 | (not (intersection initargs keywords))) |
377 | as virtual-p = (typep slotd 'effective-virtual-slot-definition) |
378 | when (and init-p virtual-p) |
379 | do (setf |
380 | (slot-value-using-class class object slotd) |
381 | (funcall (slot-definition-initfunction slotd))) |
382 | when (and init-p (not virtual-p)) |
383 | collect name))) |
384 | |
385 | (apply #'call-next-method object names initargs))) |