chiark / gitweb /
Correctly sort out string-specified getters in virtual-slots.lisp
[clg] / gffi / virtual-slots.lisp
CommitLineData
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
0bbf3105 23;; $Id: virtual-slots.lisp,v 1.11 2007-11-08 13:49:26 espen Exp $
4e968638 24
25(in-package "GFFI")
26
27;;;; Superclass for all metaclasses implementing some sort of virtual slots
28
584285fb 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)))
4e968638 39
584285fb 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
2bd78f93 61(defgeneric slot-readable-p (slotd))
62(defgeneric slot-writable-p (slotd))
584285fb 63(defgeneric compute-slot-reader-function (slotd &optional signal-unbound-p))
4e968638 64(defgeneric compute-slot-boundp-function (slotd))
65(defgeneric compute-slot-writer-function (slotd))
66(defgeneric compute-slot-makunbound-function (slotd))
67
2bd78f93 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
4e968638 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
2bd78f93 99(defmethod slot-readable-p ((slotd effective-virtual-slot-definition))
100 (slot-boundp slotd 'getter))
101
4e968638 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
584285fb 109(defmethod compute-slot-reader-function :around ((slotd effective-virtual-slot-definition) &optional (signal-unbound-p t))
2bd78f93 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
aed39f73 115 ;; Don't create wrapper to signal unbound value
2bd78f93 116 ((not signal-unbound-p) reader-function)
117
118 ;; An explicit boundp function has been supplied
119 ((slot-boundp slotd 'boundp)
2f1ec179 120 (let ((boundp (slot-value slotd 'boundp)))
2bd78f93 121 #'(lambda (object)
2f1ec179 122 (if (not (funcall boundp object))
123 (slot-unbound (class-of object) object (slot-definition-name slotd))
124 (funcall reader-function object)))))
2bd78f93 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))))))))))
584285fb 142
143(defmethod compute-slot-reader-function ((slotd effective-virtual-slot-definition) &optional signal-unbound-p)
144 (declare (ignore signal-unbound-p))
b977e63b 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))))
4e968638 151
152(defmethod compute-slot-boundp-function ((slotd effective-virtual-slot-definition))
153 (cond
2bd78f93 154 ;; Non readable slots are not bound per definition
155 ((not (slot-readable-p slotd))
156 #'(lambda (object) (declare (ignore object)) nil))
157
4e968638 158 ;; An explicit boundp function has been supplied
b977e63b 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
4e968638 167 ;; An unbound value has been supplied
168 ((slot-boundp slotd 'unbound)
584285fb 169 (let ((reader-function (compute-slot-reader-function slotd nil))
4e968638 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
584285fb 178 (let ((reader-function (compute-slot-reader-function slotd nil))
4e968638 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
2bd78f93 186(defmethod slot-writable-p ((slotd effective-virtual-slot-definition))
187 (slot-boundp slotd 'setter))
188
4e968638 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
2bd78f93 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
4e968638 203(defmethod compute-slot-writer-function ((slotd effective-virtual-slot-definition))
b977e63b 204 (let ((setter (slot-value slotd 'setter)))
205 #-sbcl setter
206 #+sbcl
207 (etypecase setter
c7a9d346 208 (symbol #'(lambda (value object) (funcall setter value object)))
209 (list #'(lambda (value object)
9f851ae5 210 (funcall setter value object)))
b977e63b 211 (function setter))))
2bd78f93 212
213(define-condition slot-can-not-be-unbound (cell-error)
214 ((instance :reader slot-can-not-be-unbound-instance :initarg :instance))
215 (:report (lambda (condition stream)
216 (format stream "~@<The slot ~S in the object ~S can not be made unbound.~@:>"
217 (cell-error-name condition)
218 (slot-can-not-be-unbound-instance condition)))))
4e968638 219
220(defmethod compute-slot-makunbound-function ((slotd effective-virtual-slot-definition))
221 (cond
2bd78f93 222 ((not (slot-writable-p slotd))
223 #'(lambda (object)
224 (error 'unwritable-slot :name (slot-definition-name slotd) :instance object)))
b977e63b 225 ((slot-boundp slotd 'makunbound)
226 (let ((makunbound (slot-value slotd 'makunbound)))
227 #-sbcl makunbound
228 #+sbcl
229 (etypecase makunbound
230 (symbol #'(lambda (object) (funcall makunbound object)))
231 (function makunbound))))
4e968638 232 ((slot-boundp slotd 'unbound)
233 #'(lambda (object)
234 (funcall (slot-value slotd 'writer-function) (slot-value slotd 'unbound) object)))
235 (t
236 #'(lambda (object)
2bd78f93 237 (error 'slot-can-not-be-unbound :name (slot-definition-name slotd) :instance object)))))
4e968638 238
239
240#-clisp
241(defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition))
1d2032d4
RS
242 #?-(sbcl>= 0 9 8)
243 (initialize-internal-slot-gfs (slot-definition-name slotd)))
4e968638 244
245
246#-clisp
247(defmethod compute-slot-accessor-info ((slotd effective-virtual-slot-definition) type gf)
248 nil)
249
584285fb 250
4e968638 251(defun slot-bound-in-some-p (instances slot)
252 (find-if
253 #'(lambda (ob)
254 (and (slot-exists-p ob slot) (slot-boundp ob slot)))
255 instances))
256
257(defun most-specific-slot-value (instances slot &optional default)
258 (let ((object (slot-bound-in-some-p instances slot)))
259 (if object
260 (slot-value object slot)
261 default)))
262
263(defun compute-most-specific-initargs (slotds slots)
264 (loop
265 for slot in slots
266 as (slot-name initarg) = (if (atom slot)
267 (list slot (intern (string slot) "KEYWORD"))
268 slot)
269 when (slot-bound-in-some-p slotds slot-name)
270 nconc (list initarg (most-specific-slot-value slotds slot-name))))
271
272(defmethod compute-effective-slot-definition-initargs ((class virtual-slots-class) direct-slotds)
273 (typecase (first direct-slotds)
274 (direct-virtual-slot-definition
275 (nconc
276 (compute-most-specific-initargs direct-slotds
277 '(getter setter unbound boundp makunbound
278 #?(or (sbcl>= 0 9 8) (featurep :clisp))
279 (#?-(sbcl>= 0 9 10)type #?(sbcl>= 0 9 10)sb-pcl::%type :type)))
280 (call-next-method)))
281 (direct-special-slot-definition
282 (append '(:special t) (call-next-method)))
283 (t (call-next-method))))
284
8f49b7a1 285(defmacro vsc-slot-x-using-class (x x-slot-name computer &key allow-string-fun-p)
1d2032d4
RS
286 (let ((generic-name (intern (concatenate 'string
287 "SLOT-" (string x) "-USING-CLASS"))))
288 `(defmethod ,generic-name
289 ((class virtual-slots-class) (object virtual-slots-object)
290 (slotd effective-virtual-slot-definition))
8f49b7a1
RS
291 (unless (and (slot-boundp slotd ',x-slot-name)
292 ,@(when allow-string-fun-p
293 `((not
294 (stringp (slot-value slotd ',x-slot-name))))))
1d2032d4
RS
295 (setf (slot-value slotd ',x-slot-name) (,computer slotd)))
296 (funcall (slot-value slotd ',x-slot-name) object))))
297
8f49b7a1
RS
298(vsc-slot-x-using-class value getter compute-slot-reader-function
299 :allow-string-fun-p t)
1d2032d4
RS
300(vsc-slot-x-using-class boundp boundp-function compute-slot-boundp-function)
301(vsc-slot-x-using-class makunbound makunbound-function
302 compute-slot-makunbound-function)
303
304(defmethod (setf slot-value-using-class) (value (class virtual-slots-class)
305 (object virtual-slots-object)
306 (slotd effective-virtual-slot-definition))
307 (unless (slot-boundp slotd 'setter)
308 (setf (slot-value slotd 'setter) (compute-slot-writer-function slotd)))
309 (funcall (slot-value slotd 'setter) value object))
4e968638 310
584285fb 311;; In CLISP and SBCL (0.9.15 or newler) a class may not have been
312;; finalized when update-slots are called. So to avoid the possibility
aed39f73 313;; of finalize-instance being called recursivly we have to delay the
584285fb 314;; initialization of slot functions until after an instance has been
315;; created.
0bbf3105 316;; 2007-11-08: done this for all implementations
317;; #?(or (sbcl>= 0 9 15) (featurep :clisp))
584285fb 318(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'reader-function)))
e3f4fceb 319 (declare (ignore class))
584285fb 320 (setf (slot-value slotd name) (compute-slot-reader-function slotd)))
4e968638 321
0bbf3105 322;; #?(or (sbcl>= 0 9 15) (featurep :clisp))
584285fb 323(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'boundp-function)))
e3f4fceb 324 (declare (ignore class))
584285fb 325 (setf (slot-value slotd name) (compute-slot-boundp-function slotd)))
326
0bbf3105 327;; #?(or (sbcl>= 0 9 15) (featurep :clisp))
584285fb 328(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'writer-function)))
e3f4fceb 329 (declare (ignore class))
584285fb 330 (setf (slot-value slotd name) (compute-slot-writer-function slotd)))
331
0bbf3105 332;; #?(or (sbcl>= 0 9 15) (featurep :clisp))
584285fb 333(defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'makunbound-function)))
e3f4fceb 334 (declare (ignore class))
584285fb 335 (setf (slot-value slotd name) (compute-slot-makunbound-function slotd)))
4e968638 336
4e968638 337
338(defmethod validate-superclass
339 ((class virtual-slots-class) (super standard-class))
340 t)
341
342(defmethod slot-definition-special ((slotd standard-direct-slot-definition))
343 (declare (ignore slotd))
344 nil)
345
346(defmethod slot-definition-special ((slotd standard-effective-slot-definition))
347 (declare (ignore slotd))
348 nil)
349
350
4e968638 351;;; To determine if a slot should be initialized with the initform,
352;;; CLISP checks whether it is unbound or not. This doesn't work with
aed39f73 353;;; virtual slots that does not have an unbound state, so we have to
4e968638 354;;; implement initform initialization in a way similar to how it is
355;;; done in PCL.
356#+clisp
357(defmethod shared-initialize ((object virtual-slots-object) names &rest initargs)
358 (let* ((class (class-of object))
359 (slotds (class-slots class))
360 (keywords (loop
361 for args on initargs by #'cddr
362 collect (first args)))
363 (names
364 (loop
365 for slotd in slotds
366 as name = (slot-definition-name slotd)
367 as initargs = (slot-definition-initargs slotd)
368 as init-p = (and
369 (or (eq names t) (find name names))
370 (slot-definition-initfunction slotd)
371 (not (intersection initargs keywords)))
372 as virtual-p = (typep slotd 'effective-virtual-slot-definition)
373 when (and init-p virtual-p)
374 do (setf
375 (slot-value-using-class class object slotd)
376 (funcall (slot-definition-initfunction slotd)))
377 when (and init-p (not virtual-p))
378 collect name)))
379
380 (apply #'call-next-method object names initargs)))