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