4e968638 |
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 | |
23 | ;; $Id: virtual-slots.lisp,v 1.1 2006-04-25 20:49:16 espen Exp $ |
24 | |
25 | (in-package "GFFI") |
26 | |
27 | ;;;; Superclass for all metaclasses implementing some sort of virtual slots |
28 | |
29 | (eval-when (:compile-toplevel :load-toplevel :execute) |
30 | (defclass virtual-slots-class (standard-class) |
31 | ()) |
32 | |
33 | (defclass direct-virtual-slot-definition (standard-direct-slot-definition) |
34 | ((setter :reader slot-definition-setter :initarg :setter) |
35 | (getter :reader slot-definition-getter :initarg :getter) |
36 | (unbound :reader slot-definition-unbound :initarg :unbound) |
37 | (boundp :reader slot-definition-boundp :initarg :boundp) |
38 | (makunbound :reader slot-definition-makunbound :initarg :makunbound) |
39 | #+clisp(type :initarg :type :reader slot-definition-type))) |
40 | |
41 | (defclass effective-virtual-slot-definition (standard-effective-slot-definition) |
42 | ((setter :reader slot-definition-setter :initarg :setter) |
43 | (getter :reader slot-definition-getter :initarg :getter) |
44 | (unbound :reader slot-definition-unbound :initarg :unbound) |
45 | (boundp :reader slot-definition-boundp :initarg :boundp) |
46 | (makunbound :reader slot-definition-makunbound :initarg :makunbound) |
47 | #+clisp(reader-function) |
48 | #+clisp(writer-function) |
49 | #+clisp(boundp-function) |
50 | makunbound-function |
51 | #+clisp(type :initarg :type :reader slot-definition-type))) |
52 | |
53 | (defclass direct-special-slot-definition (standard-direct-slot-definition) |
54 | ((special :initarg :special :accessor slot-definition-special))) |
55 | |
56 | (defclass effective-special-slot-definition (standard-effective-slot-definition) |
57 | ((special :initarg :special :accessor slot-definition-special)))) |
58 | |
59 | (defgeneric compute-slot-reader-function (slotd)) |
60 | (defgeneric compute-slot-boundp-function (slotd)) |
61 | (defgeneric compute-slot-writer-function (slotd)) |
62 | (defgeneric compute-slot-makunbound-function (slotd)) |
63 | |
64 | |
65 | #+clisp |
66 | (defmethod slot-definition-type ((slotd t)) |
67 | (clos:slot-definition-type slotd)) |
68 | |
69 | |
70 | (defmethod direct-slot-definition-class ((class virtual-slots-class) &rest initargs) |
71 | (cond |
72 | ((eq (getf initargs :allocation) :virtual) |
73 | (find-class 'direct-virtual-slot-definition)) |
74 | ((getf initargs :special) |
75 | (find-class 'direct-special-slot-definition)) |
76 | (t (call-next-method)))) |
77 | |
78 | (defmethod effective-slot-definition-class ((class virtual-slots-class) &rest initargs) |
79 | (cond |
80 | ((eq (getf initargs :allocation) :virtual) |
81 | (find-class 'effective-virtual-slot-definition)) |
82 | ((getf initargs :special) |
83 | (find-class 'effective-special-slot-definition)) |
84 | (t (call-next-method)))) |
85 | |
86 | |
87 | (define-condition unreadable-slot (cell-error) |
88 | ((instance :reader unreadable-slot-instance :initarg :instance)) |
89 | (:report (lambda (condition stream) |
90 | (format stream "~@<The slot ~S in the object ~S is not readable.~@:>" |
91 | (cell-error-name condition) |
92 | (unreadable-slot-instance condition))))) |
93 | |
94 | (defmethod compute-slot-reader-function ((slotd effective-virtual-slot-definition)) |
95 | (if (slot-boundp slotd 'getter) |
96 | (slot-value slotd 'getter) |
97 | #'(lambda (object) |
98 | (error 'unreadable-slot :name (slot-definition-name slotd) :instance object)))) |
99 | |
100 | (defmethod compute-slot-boundp-function ((slotd effective-virtual-slot-definition)) |
101 | (cond |
102 | ;; An explicit boundp function has been supplied |
103 | ((slot-boundp slotd 'boundp) (slot-value slotd 'boundp)) |
104 | |
105 | ;; An unbound value has been supplied |
106 | ((slot-boundp slotd 'unbound) |
107 | (let ((reader-function (slot-value slotd 'reader-function)) |
108 | (unbound-value (slot-value slotd 'unbound))) |
109 | #'(lambda (object) |
110 | (not (eql (funcall reader-function object) unbound-value))))) |
111 | |
112 | ;; A type unbound value exists |
113 | ((let ((unbound-method (find-applicable-type-method 'unbound-value |
114 | (slot-definition-type slotd) nil))) |
115 | (when unbound-method |
116 | (let ((reader-function (slot-value slotd 'reader-function)) |
117 | (unbound-value (funcall unbound-method (slot-definition-type slotd)))) |
118 | #'(lambda (object) |
119 | (not (eql (funcall reader-function object) unbound-value))))))) |
120 | |
121 | ;; Slot has no unbound state |
122 | (#'(lambda (object) (declare (ignore object)) t)))) |
123 | |
124 | (define-condition unwritable-slot (cell-error) |
125 | ((instance :reader unwritable-slot-instance :initarg :instance)) |
126 | (:report (lambda (condition stream) |
127 | (format stream "~@<The slot ~S in the object ~S is not writable.~@:>" |
128 | (cell-error-name condition) |
129 | (unwritable-slot-instance condition))))) |
130 | |
131 | (defmethod compute-slot-writer-function ((slotd effective-virtual-slot-definition)) |
132 | (if (slot-boundp slotd 'setter) |
133 | (slot-value slotd 'setter) |
134 | #'(lambda (value object) |
135 | (declare (ignore value)) |
136 | (error 'unwritable-slot :name (slot-definition-name slotd) :instance object)))) |
137 | |
138 | (defmethod compute-slot-makunbound-function ((slotd effective-virtual-slot-definition)) |
139 | (cond |
140 | ((slot-boundp slotd 'makunbound) (slot-value slotd 'makunbound)) |
141 | ((slot-boundp slotd 'unbound) |
142 | #'(lambda (object) |
143 | (funcall (slot-value slotd 'writer-function) (slot-value slotd 'unbound) object))) |
144 | (t |
145 | #'(lambda (object) |
146 | (error 'unwritable-slot :name (slot-definition-name slotd) :instance object))))) |
147 | |
148 | |
149 | #-clisp |
150 | (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition)) |
151 | (setf |
152 | (slot-value slotd 'reader-function) (compute-slot-reader-function slotd) |
153 | (slot-value slotd 'boundp-function) (compute-slot-boundp-function slotd) |
154 | (slot-value slotd 'writer-function) (compute-slot-writer-function slotd) |
155 | (slot-value slotd 'makunbound-function) (compute-slot-makunbound-function slotd)) |
156 | |
157 | #?-(sbcl>= 0 9 8)(initialize-internal-slot-gfs (slot-definition-name slotd))) |
158 | |
159 | |
160 | #-clisp |
161 | (defmethod compute-slot-accessor-info ((slotd effective-virtual-slot-definition) type gf) |
162 | nil) |
163 | |
164 | (defun slot-bound-in-some-p (instances slot) |
165 | (find-if |
166 | #'(lambda (ob) |
167 | (and (slot-exists-p ob slot) (slot-boundp ob slot))) |
168 | instances)) |
169 | |
170 | (defun most-specific-slot-value (instances slot &optional default) |
171 | (let ((object (slot-bound-in-some-p instances slot))) |
172 | (if object |
173 | (slot-value object slot) |
174 | default))) |
175 | |
176 | (defun compute-most-specific-initargs (slotds slots) |
177 | (loop |
178 | for slot in slots |
179 | as (slot-name initarg) = (if (atom slot) |
180 | (list slot (intern (string slot) "KEYWORD")) |
181 | slot) |
182 | when (slot-bound-in-some-p slotds slot-name) |
183 | nconc (list initarg (most-specific-slot-value slotds slot-name)))) |
184 | |
185 | (defmethod compute-effective-slot-definition-initargs ((class virtual-slots-class) direct-slotds) |
186 | (typecase (first direct-slotds) |
187 | (direct-virtual-slot-definition |
188 | (nconc |
189 | (compute-most-specific-initargs direct-slotds |
190 | '(getter setter unbound boundp makunbound |
191 | #?(or (sbcl>= 0 9 8) (featurep :clisp)) |
192 | (#?-(sbcl>= 0 9 10)type #?(sbcl>= 0 9 10)sb-pcl::%type :type))) |
193 | (call-next-method))) |
194 | (direct-special-slot-definition |
195 | (append '(:special t) (call-next-method))) |
196 | (t (call-next-method)))) |
197 | |
198 | |
199 | (defmethod slot-value-using-class |
200 | ((class virtual-slots-class) (object standard-object) |
201 | (slotd effective-virtual-slot-definition)) |
202 | ;; This isn't optimal when we have an unbound value, as the reader |
203 | ;; function gets invoke twice |
204 | (if (funcall (slot-value slotd 'boundp-function) object) |
205 | (funcall (slot-value slotd 'reader-function) object) |
206 | (slot-unbound class object (slot-definition-name slotd)))) |
207 | |
208 | (defmethod slot-boundp-using-class |
209 | ((class virtual-slots-class) (object standard-object) |
210 | (slotd effective-virtual-slot-definition)) |
211 | (handler-case |
212 | (funcall (slot-value slotd 'boundp-function) object) |
213 | (unreadable-slot (condition) |
214 | (declare (ignore condition)) |
215 | nil))) |
216 | |
217 | (defmethod (setf slot-value-using-class) |
218 | (value (class virtual-slots-class) (object standard-object) |
219 | (slotd effective-virtual-slot-definition)) |
220 | (funcall (slot-value slotd 'writer-function) value object)) |
221 | |
222 | (defmethod slot-makunbound-using-class |
223 | ((class virtual-slots-class) (object standard-object) |
224 | (slotd effective-virtual-slot-definition)) |
225 | (funcall (slot-value slotd 'makunbound-function) object)) |
226 | |
227 | |
228 | ;; In CLISP a class may not have been finalized when update-slots are |
229 | ;; called. So to avoid the possibility of finalize-instance beeing |
230 | ;; called recursivly we have to delay the initialization of slot |
231 | ;; functions until after an instance has been created. We therefor do |
232 | ;; it in around methods for the generic functions used to access |
233 | ;; slots. |
234 | #+clisp |
235 | (defmethod slot-value-using-class :around ((class virtual-slots-class) (object standard-object) (slotd effective-virtual-slot-definition)) |
236 | (unless (slot-boundp slotd 'reader-function) |
237 | (setf |
238 | (slot-value slotd 'reader-function) (compute-slot-reader-function slotd) |
239 | (slot-value slotd 'boundp-function) (compute-slot-boundp-function slotd))) |
240 | (call-next-method)) |
241 | |
242 | #+clisp |
243 | (defmethod slot-boundp-using-class :around ((class virtual-slots-class) (object standard-object) (slotd effective-virtual-slot-definition)) |
244 | (unless (slot-boundp slotd 'boundp-function) |
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 | (call-next-method)) |
249 | |
250 | #+clisp |
251 | (defmethod (setf slot-value-using-class) :around (value (class virtual-slots-class) (object standard-object) (slotd effective-virtual-slot-definition)) |
252 | (declare (ignore value)) |
253 | (unless (slot-boundp slotd 'writer-function) |
254 | (setf |
255 | (slot-value slotd 'writer-function) (compute-slot-writer-function slotd))) |
256 | (call-next-method)) |
257 | |
258 | #+clisp |
259 | (defmethod slot-makunbound-using-class :around ((class virtual-slots-class) (object standard-object) (slotd effective-virtual-slot-definition)) |
260 | (unless (slot-boundp slotd 'makunbound-function) |
261 | (setf |
262 | (slot-value slotd 'makunbound-function) |
263 | (compute-slot-makunbound-function slotd))) |
264 | (call-next-method)) |
265 | |
266 | (defmethod validate-superclass |
267 | ((class virtual-slots-class) (super standard-class)) |
268 | t) |
269 | |
270 | (defmethod slot-definition-special ((slotd standard-direct-slot-definition)) |
271 | (declare (ignore slotd)) |
272 | nil) |
273 | |
274 | (defmethod slot-definition-special ((slotd standard-effective-slot-definition)) |
275 | (declare (ignore slotd)) |
276 | nil) |
277 | |
278 | |
279 | (defclass virtual-slots-object (standard-object) |
280 | ()) |
281 | |
282 | |
283 | ;;; To determine if a slot should be initialized with the initform, |
284 | ;;; CLISP checks whether it is unbound or not. This doesn't work with |
285 | ;;; virtual slots which does not have an unbound state, so we have to |
286 | ;;; implement initform initialization in a way similar to how it is |
287 | ;;; done in PCL. |
288 | #+clisp |
289 | (defmethod shared-initialize ((object virtual-slots-object) names &rest initargs) |
290 | (let* ((class (class-of object)) |
291 | (slotds (class-slots class)) |
292 | (keywords (loop |
293 | for args on initargs by #'cddr |
294 | collect (first args))) |
295 | (names |
296 | (loop |
297 | for slotd in slotds |
298 | as name = (slot-definition-name slotd) |
299 | as initargs = (slot-definition-initargs slotd) |
300 | as init-p = (and |
301 | (or (eq names t) (find name names)) |
302 | (slot-definition-initfunction slotd) |
303 | (not (intersection initargs keywords))) |
304 | as virtual-p = (typep slotd 'effective-virtual-slot-definition) |
305 | when (and init-p virtual-p) |
306 | do (setf |
307 | (slot-value-using-class class object slotd) |
308 | (funcall (slot-definition-initfunction slotd))) |
309 | when (and init-p (not virtual-p)) |
310 | collect name))) |
311 | |
312 | (apply #'call-next-method object names initargs))) |