chiark / gitweb /
Fix compilation for Gtk with the new, stricter inheritance
[clg] / gffi / virtual-slots.lisp
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.11 2007-11-08 13:49:26 espen Exp $
24
25 (in-package "GFFI")
26
27 ;;;; Superclass for all metaclasses implementing some sort of virtual slots
28
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)))
39   
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
61 (defgeneric slot-readable-p (slotd))
62 (defgeneric slot-writable-p (slotd))
63 (defgeneric compute-slot-reader-function (slotd &optional signal-unbound-p))
64 (defgeneric compute-slot-boundp-function (slotd))
65 (defgeneric compute-slot-writer-function (slotd))
66 (defgeneric compute-slot-makunbound-function (slotd))
67
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
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
99 (defmethod slot-readable-p ((slotd effective-virtual-slot-definition))
100   (slot-boundp slotd 'getter))
101
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
109 (defmethod compute-slot-reader-function :around ((slotd effective-virtual-slot-definition) &optional (signal-unbound-p t))
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
115        ;; Don't create wrapper to signal unbound value
116        ((not signal-unbound-p) reader-function)
117        
118        ;; An explicit boundp function has been supplied
119        ((slot-boundp slotd 'boundp) 
120         (let ((boundp (slot-value slotd 'boundp)))
121           #'(lambda (object)
122               (if (not (funcall boundp object))
123                   (slot-unbound (class-of object) object (slot-definition-name slotd))
124                 (funcall reader-function object)))))
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))))))))))
142
143 (defmethod compute-slot-reader-function ((slotd effective-virtual-slot-definition) &optional signal-unbound-p)
144   (declare (ignore signal-unbound-p))
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))))
151
152 (defmethod compute-slot-boundp-function ((slotd effective-virtual-slot-definition))
153   (cond
154    ;; Non readable slots are not bound per definition
155    ((not (slot-readable-p slotd))
156     #'(lambda (object) (declare (ignore object)) nil))
157
158    ;; An explicit boundp function has been supplied
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
167    ;; An unbound value has been supplied
168    ((slot-boundp slotd 'unbound)
169     (let ((reader-function (compute-slot-reader-function slotd nil))
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
178         (let ((reader-function (compute-slot-reader-function slotd nil))
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
186 (defmethod slot-writable-p ((slotd effective-virtual-slot-definition))
187   (slot-boundp slotd 'setter))
188
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
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
203 (defmethod compute-slot-writer-function ((slotd effective-virtual-slot-definition))
204   (let ((setter (slot-value slotd 'setter)))
205     #-sbcl setter
206     #+sbcl
207     (etypecase setter
208       (symbol #'(lambda (value object) (funcall setter value object)))
209       (list #'(lambda (value object)
210                 (funcall setter value object)))
211       (function setter))))
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)))))
219
220 (defmethod compute-slot-makunbound-function ((slotd effective-virtual-slot-definition))
221   (cond
222    ((not (slot-writable-p slotd))
223     #'(lambda (object)
224         (error 'unwritable-slot :name (slot-definition-name slotd) :instance object)))
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))))
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)
237         (error 'slot-can-not-be-unbound :name (slot-definition-name slotd) :instance object)))))
238
239
240 #-clisp
241 (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition))
242 ;;   #?-(sbcl>= 0 9 15) ; Delayed to avoid recursive call of finalize-inheritanze
243   #+nil ;; 2007-11-08: done this for all implementations
244   (setf 
245    (slot-value slotd 'reader-function) (compute-slot-reader-function slotd)
246    (slot-value slotd 'boundp-function) (compute-slot-boundp-function slotd)
247    (slot-value slotd 'writer-function) (compute-slot-writer-function slotd)
248    (slot-value slotd 'makunbound-function) (compute-slot-makunbound-function slotd))
249
250   #?-(sbcl>= 0 9 8)(initialize-internal-slot-gfs (slot-definition-name slotd)))
251
252
253 #-clisp
254 (defmethod compute-slot-accessor-info ((slotd effective-virtual-slot-definition) type gf)
255   nil)
256
257
258 (defun slot-bound-in-some-p (instances slot)
259   (find-if
260    #'(lambda (ob)
261        (and (slot-exists-p ob slot) (slot-boundp ob slot)))
262    instances))
263
264 (defun most-specific-slot-value (instances slot &optional default)
265   (let ((object (slot-bound-in-some-p instances slot)))
266     (if object
267         (slot-value object slot)
268       default)))
269
270 (defun compute-most-specific-initargs (slotds slots)
271   (loop
272    for slot in slots
273    as (slot-name initarg) = (if (atom slot)
274                                 (list slot (intern (string slot) "KEYWORD"))
275                               slot)
276    when (slot-bound-in-some-p slotds slot-name)
277    nconc (list initarg (most-specific-slot-value slotds slot-name))))
278
279 (defmethod compute-effective-slot-definition-initargs ((class virtual-slots-class) direct-slotds)
280   (typecase (first direct-slotds)
281     (direct-virtual-slot-definition
282      (nconc
283       (compute-most-specific-initargs direct-slotds
284        '(getter setter unbound boundp makunbound
285          #?(or (sbcl>= 0 9 8) (featurep :clisp))
286          (#?-(sbcl>= 0 9 10)type #?(sbcl>= 0 9 10)sb-pcl::%type :type)))
287       (call-next-method)))
288     (direct-special-slot-definition
289      (append '(:special t) (call-next-method)))
290     (t (call-next-method))))
291
292 #?(or (not (sbcl>= 0 9 14)) (featurep :clisp))
293 (defmethod slot-value-using-class
294     ((class virtual-slots-class) (object virtual-slots-object)
295      (slotd effective-virtual-slot-definition))
296     (funcall (slot-value slotd 'reader-function) object))
297
298 #?(or (not (sbcl>= 0 9 14)) (featurep :clisp))
299 (defmethod slot-boundp-using-class
300     ((class virtual-slots-class) (object virtual-slots-object)
301      (slotd effective-virtual-slot-definition))
302     (funcall (slot-value slotd 'boundp-function) object))
303
304 #?(or (not (sbcl>= 0 9 14)) (featurep :clisp))
305 (defmethod (setf slot-value-using-class) 
306     (value (class virtual-slots-class) (object virtual-slots-object)
307      (slotd effective-virtual-slot-definition))
308   (funcall (slot-value slotd 'writer-function) value object))
309
310 (defmethod slot-makunbound-using-class
311     ((class virtual-slots-class) (object virtual-slots-object)
312      (slotd effective-virtual-slot-definition))
313   (funcall (slot-value slotd 'makunbound-function) object))
314
315
316 ;; In CLISP and SBCL (0.9.15 or newler) a class may not have been
317 ;; finalized when update-slots are called. So to avoid the possibility
318 ;; of finalize-instance being called recursivly we have to delay the
319 ;; initialization of slot functions until after an instance has been
320 ;; created.
321 ;; 2007-11-08: done this for all implementations
322 ;; #?(or (sbcl>= 0 9 15) (featurep :clisp))
323 (defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'reader-function)))
324   (declare (ignore class))
325   (setf (slot-value slotd name) (compute-slot-reader-function slotd)))
326
327 ;; #?(or (sbcl>= 0 9 15) (featurep :clisp))
328 (defmethod slot-unbound (class (slotd effective-virtual-slot-definition) (name (eql 'boundp-function)))
329   (declare (ignore class))
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)))
334   (declare (ignore class))
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)))
339   (declare (ignore class))
340   (setf (slot-value slotd name) (compute-slot-makunbound-function slotd)))
341
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
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
358 ;;; virtual slots that does not have an unbound state, so we have to
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)))