chiark / gitweb /
Fixed some compiler warnings
[clg] / glib / proxy.lisp
CommitLineData
94f15c3c 1;; Common Lisp bindings for GTK+ v2.0
2;; Copyright (C) 2000 Espen S. Johnsen <esj@stud.cs.uit.no>
3;;
4;; This library is free software; you can redistribute it and/or
5;; modify it under the terms of the GNU Lesser General Public
6;; License as published by the Free Software Foundation; either
7;; version 2 of the License, or (at your option) any later version.
8;;
9;; This library is distributed in the hope that it will be useful,
10;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
12;; Lesser General Public License for more details.
13;;
14;; You should have received a copy of the GNU Lesser General Public
15;; License along with this library; if not, write to the Free Software
16;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
17
81594ec4 18;; $Id: proxy.lisp,v 1.7 2002-01-20 14:52:04 espen Exp $
94f15c3c 19
20(in-package "GLIB")
21
22
23;;;; Superclass for all metaclasses implementing some sort of virtual slots
24
25(eval-when (:compile-toplevel :load-toplevel :execute)
12d0437e 26 (defclass virtual-slot-class (pcl::standard-class))
94f15c3c 27
28 (defclass direct-virtual-slot-definition (standard-direct-slot-definition)
12d0437e 29 ((setter :reader slot-definition-setter :initarg :setter)
30 (getter :reader slot-definition-getter :initarg :getter)))
94f15c3c 31
32 (defclass effective-virtual-slot-definition
33 (standard-effective-slot-definition)))
34
35
12d0437e 36(defmethod direct-slot-definition-class ((class virtual-slot-class) initargs)
94f15c3c 37 (if (eq (getf initargs :allocation) :virtual)
38 (find-class 'direct-virtual-slot-definition)
39 (call-next-method)))
40
12d0437e 41(defmethod effective-slot-definition-class ((class virtual-slot-class) initargs)
94f15c3c 42 (if (eq (getf initargs :allocation) :virtual)
43 (find-class 'effective-virtual-slot-definition)
44 (call-next-method)))
45
12d0437e 46(defun %most-specific-slot-value (slotds slot &optional default)
94f15c3c 47 (let ((slotd
48 (find-if
49 #'(lambda (slotd)
50 (and
51 (slot-exists-p slotd slot)
52 (slot-boundp slotd slot)))
53 slotds)))
54 (if slotd
55 (slot-value slotd slot)
56 default)))
12d0437e 57
58(defgeneric compute-virtual-slot-accessors (class slotd direct-slotds))
94f15c3c 59
12d0437e 60(defmethod compute-virtual-slot-accessors
61 ((class virtual-slot-class)
94f15c3c 62 (slotd effective-virtual-slot-definition)
63 direct-slotds)
12d0437e 64 (let ((getter (%most-specific-slot-value direct-slotds 'getter))
65 (setter (%most-specific-slot-value direct-slotds 'setter)))
66 (list getter setter)))
94f15c3c 67
68(defmethod compute-effective-slot-definition
12d0437e 69 ((class virtual-slot-class) direct-slotds)
94f15c3c 70 (let ((slotd (call-next-method)))
71 (when (typep slotd 'effective-virtual-slot-definition)
72 (setf
73 (slot-value slotd 'pcl::location)
12d0437e 74 (compute-virtual-slot-accessors class slotd direct-slotds)))
94f15c3c 75 slotd))
76
94f15c3c 77(defmethod slot-value-using-class
12d0437e 78 ((class virtual-slot-class) (object standard-object)
94f15c3c 79 (slotd effective-virtual-slot-definition))
80 (let ((reader (first (slot-definition-location slotd))))
81 (if reader
82 (funcall reader object)
83 (slot-unbound class object (slot-definition-name slotd)))))
84
94f15c3c 85(defmethod slot-boundp-using-class
12d0437e 86 ((class virtual-slot-class) (object standard-object)
94f15c3c 87 (slotd effective-virtual-slot-definition))
88 (and (first (slot-definition-location slotd)) t))
89
94f15c3c 90(defmethod (setf slot-value-using-class)
12d0437e 91 (value (class virtual-slot-class) (object standard-object)
94f15c3c 92 (slotd effective-virtual-slot-definition))
12d0437e 93 (let ((setter (second (slot-definition-location slotd))))
94f15c3c 94 (cond
12d0437e 95 ((null setter)
94f15c3c 96 (error
97 "Can't set read-only slot ~A in ~A"
98 (slot-definition-name slotd)
99 object))
12d0437e 100 ((or (functionp setter) (symbolp setter))
101 (funcall setter value object)
94f15c3c 102 value)
103 (t
12d0437e 104 (funcall (fdefinition setter) value object)
94f15c3c 105 value))))
106
94f15c3c 107(defmethod validate-superclass
12d0437e 108 ((class virtual-slot-class) (super pcl::standard-class))
94f15c3c 109 t)
110
111
112;;;; Proxy cache
113
114(internal *instance-cache*)
115(defvar *instance-cache* (make-hash-table :test #'eql))
116
117(defun cache-instance (instance)
118 (setf
119 (gethash (system:sap-int (proxy-location instance)) *instance-cache*)
120 (ext:make-weak-pointer instance)))
121
122(defun find-cached-instance (location)
123 (let ((ref (gethash (system:sap-int location) *instance-cache*)))
124 (when ref
125 (ext:weak-pointer-value ref))))
126
127(defun remove-cached-instance (location)
128 (remhash (system:sap-int location) *instance-cache*))
129
130
131
132;;;; Proxy for alien instances
133
134(eval-when (:compile-toplevel :load-toplevel :execute)
135 (defclass proxy ()
12d0437e 136 ((location :reader proxy-location :type system-area-pointer)))
94f15c3c 137
138 (defgeneric initialize-proxy (object &rest initargs))
139 (defgeneric instance-finalizer (object)))
140
141
142(defmethod initialize-instance :after ((instance proxy)
143 &rest initargs &key)
144 (declare (ignore initargs))
145 (cache-instance instance)
146 (ext:finalize instance (instance-finalizer instance)))
147
94f15c3c 148(defmethod initialize-proxy ((instance proxy)
12d0437e 149 &rest initargs &key location weak-ref)
94f15c3c 150 (declare (ignore initargs))
12d0437e 151 (setf
152 (slot-value instance 'location)
153 (if weak-ref
154 (funcall
155 (proxy-class-copy (class-of instance))
156 (type-of instance) location)
157 location))
158 (cache-instance instance)
159 (ext:finalize instance (instance-finalizer instance)))
94f15c3c 160
161(defmethod instance-finalizer ((instance proxy))
12d0437e 162 (let ((free (proxy-class-free (class-of instance)))
163 (type (type-of instance))
164 (location (proxy-location instance)))
165 (declare
166 (type symbol type)
167 (type system-area-pointer location))
94f15c3c 168 #'(lambda ()
12d0437e 169 (funcall free type location)
94f15c3c 170 (remove-cached-instance location))))
171
172
173(deftype-method translate-type-spec proxy (type-spec)
174 (declare (ignore type-spec))
175 (translate-type-spec 'pointer))
176
177(deftype-method size-of proxy (type-spec)
178 (declare (ignore type-spec))
179 (size-of 'pointer))
180
181(deftype-method translate-from-alien
182 proxy (type-spec location &optional weak-ref)
183 `(let ((location ,location))
184 (unless (null-pointer-p location)
185 (ensure-proxy-instance ',type-spec location ,weak-ref))))
186
12d0437e 187(deftype-method translate-to-alien
188 proxy (type-spec instance &optional weak-ref)
189 (if weak-ref
190 `(proxy-location ,instance)
191 `(funcall
4068d820 192 ',(proxy-class-copy (find-class type-spec))
12d0437e 193 ',type-spec (proxy-location ,instance))))
94f15c3c 194
12d0437e 195(deftype-method unreference-alien proxy (type-spec location)
4068d820 196 `(funcall ',(proxy-class-free (find-class type-spec)) ',type-spec ,location))
12d0437e 197
198(defun proxy-instance-size (proxy)
199 (proxy-class-size (class-of proxy)))
94f15c3c 200
201;;;; Metaclass used for subclasses of proxy
202
203(eval-when (:compile-toplevel :load-toplevel :execute)
12d0437e 204 (defclass proxy-class (virtual-slot-class)
205 ((size :reader proxy-class-size)
206 (copy :reader proxy-class-copy)
207 (free :reader proxy-class-free)))
94f15c3c 208
209 (defclass direct-alien-slot-definition (direct-virtual-slot-definition)
12d0437e 210 ((allocation :initform :alien)
211 (offset :reader slot-definition-offset :initarg :offset)))
94f15c3c 212
213 (defclass effective-alien-slot-definition (effective-virtual-slot-definition)
214 ((offset :reader slot-definition-offset)))
215
216 (defclass effective-virtual-alien-slot-definition
217 (effective-virtual-slot-definition))
12d0437e 218
94f15c3c 219
220 (defmethod most-specific-proxy-superclass ((class proxy-class))
221 (find-if
222 #'(lambda (class)
223 (subtypep (class-name class) 'proxy))
224 (cdr (pcl::compute-class-precedence-list class))))
225
12d0437e 226 (defmethod direct-proxy-superclass ((class proxy-class))
227 (find-if
228 #'(lambda (class)
229 (subtypep (class-name class) 'proxy))
230 (pcl::class-direct-superclasses class)))
94f15c3c 231
232 (defmethod shared-initialize ((class proxy-class) names
12d0437e 233 &rest initargs &key size copy free)
94f15c3c 234 (declare (ignore initargs))
235 (call-next-method)
12d0437e 236 (cond
237 (size (setf (slot-value class 'size) (first size)))
238 ((slot-boundp class 'size) (slot-makunbound class 'size)))
239 (cond
240 (copy (setf (slot-value class 'copy) (first copy)))
241 ((slot-boundp class 'copy) (slot-makunbound class 'copy)))
242 (cond
243 (free (setf (slot-value class 'free) (first free)))
244 ((slot-boundp class 'free) (slot-makunbound class 'free))))
94f15c3c 245
12d0437e 246 (defmethod finalize-inheritance ((class proxy-class))
247 (call-next-method)
3e15002d 248 (let ((super (most-specific-proxy-superclass class)))
249 (unless (or (not super) (eq super (find-class 'proxy)))
12d0437e 250 (unless (or (slot-boundp class 'copy) (not (slot-boundp super 'copy)))
251 (setf (slot-value class 'copy) (proxy-class-copy super)))
252 (unless (or (slot-boundp class 'free) (not (slot-boundp super 'free)))
253 (setf (slot-value class 'free) (proxy-class-free super))))))
94f15c3c 254
255 (defmethod direct-slot-definition-class ((class proxy-class) initargs)
256 (case (getf initargs :allocation)
257 ((nil :alien) (find-class 'direct-alien-slot-definition))
258; (:instance (error "Allocation :instance not allowed in class ~A" class))
259 (t (call-next-method))))
260
94f15c3c 261 (defmethod effective-slot-definition-class ((class proxy-class) initargs)
262 (case (getf initargs :allocation)
263 (:alien (find-class 'effective-alien-slot-definition))
264 (:virtual (find-class 'effective-virtual-alien-slot-definition))
265 (t (call-next-method))))
266
12d0437e 267 (defmethod compute-virtual-slot-accessors
94f15c3c 268 ((class proxy-class) (slotd effective-alien-slot-definition)
269 direct-slotds)
270 (with-slots (offset type) slotd
94f15c3c 271 (let ((reader (intern-reader-function type))
272 (writer (intern-writer-function type))
273 (destroy (intern-destroy-function type)))
12d0437e 274 (setf offset (slot-definition-offset (first direct-slotds)))
94f15c3c 275 (list
276 #'(lambda (object)
277 (funcall reader (proxy-location object) offset))
278 #'(lambda (value object)
279 (let ((location (proxy-location object)))
280 (funcall destroy location offset)
281 (funcall writer value location offset)))))))
12d0437e 282
283 (defmethod compute-virtual-slot-accessors
94f15c3c 284 ((class proxy-class)
285 (slotd effective-virtual-alien-slot-definition)
286 direct-slotds)
12d0437e 287 (destructuring-bind (getter setter) (call-next-method)
81594ec4 288 (with-slots (type) slotd
289 (list
290 (if (stringp getter)
291 (let ((getter (mkbinding-late getter type 'pointer)))
292 #'(lambda (object)
293 (funcall getter (proxy-location object))))
294 getter)
295 (if (stringp setter)
296 (let ((setter (mkbinding-late setter 'nil 'pointer type)))
297 #'(lambda (value object)
298 (funcall setter (proxy-location object) value)))
299 setter)))))
94f15c3c 300
301 (defmethod compute-slots ((class proxy-class))
12d0437e 302 (with-slots (direct-slots size) class
303 (let ((current-offset
304 (proxy-class-size (most-specific-proxy-superclass class)))
305 (max-size 0))
94f15c3c 306 (dolist (slotd direct-slots)
307 (when (eq (slot-definition-allocation slotd) :alien)
308 (with-slots (offset type) slotd
12d0437e 309 (unless (slot-boundp slotd 'offset)
310 (setf offset current-offset))
311 (setq current-offset (+ offset (size-of type)))
312 (setq max-size (max max-size current-offset)))))
313 (unless (slot-boundp class 'size)
314 (setf size max-size))))
94f15c3c 315 (call-next-method))
12d0437e 316
94f15c3c 317 (defmethod validate-superclass ((class proxy-class)
318 (super pcl::standard-class))
12d0437e 319 (subtypep (class-name super) 'proxy))
3e15002d 320
12d0437e 321 (defmethod proxy-class-size (class)
322 (declare (ignore class))
323 0)
94f15c3c 324
12d0437e 325 (defgeneric make-proxy-instance (class location weak-ref
326 &rest initargs &key)))
94f15c3c 327
328(defmethod make-proxy-instance ((class symbol) location weak-ref
329 &rest initargs &key)
330 (apply #'make-proxy-instance (find-class class) location weak-ref initargs))
331
332(defmethod make-proxy-instance ((class proxy-class) location weak-ref
333 &rest initargs &key)
334 (let ((instance (allocate-instance class)))
335 (apply
336 #'initialize-proxy
337 instance :location location :weak-ref weak-ref initargs)
338 instance))
339
340(defun ensure-proxy-instance (class location weak-ref &rest initargs)
341 (or
342 (find-cached-instance location)
343 (apply #'make-proxy-instance class location weak-ref initargs)))
344
345
12d0437e 346
347;;;; Superclasses for wrapping of C structures
94f15c3c 348
349(eval-when (:compile-toplevel :load-toplevel :execute)
12d0437e 350 (defclass struct (proxy)
94f15c3c 351 ()
352 (:metaclass proxy-class)
12d0437e 353 (:copy %copy-struct)
354 (:free %free-struct)))
94f15c3c 355
12d0437e 356(defmethod initialize-instance ((structure struct)
94f15c3c 357 &rest initargs)
358 (declare (ignore initargs))
359 (setf
360 (slot-value structure 'location)
12d0437e 361 (allocate-memory (proxy-class-size (class-of structure))))
94f15c3c 362 (call-next-method))
363
364
12d0437e 365(defun %copy-struct (type location)
366 (copy-memory location (proxy-class-size (find-class type))))
94f15c3c 367
12d0437e 368(defun %free-struct (type location)
369 (declare (ignore type))
370 (deallocate-memory location))
94f15c3c 371
372
3e15002d 373;(eval-when (:compile-toplevel :load-toplevel :execute)
12d0437e 374 (defclass static (struct)
375 ()
3e15002d 376 (:metaclass proxy-class)
377 (:copy %copy-static)
378 (:free %free-static));)
94f15c3c 379
12d0437e 380(defun %copy-static (type location)
381 (declare (ignore type))
382 location)
94f15c3c 383
12d0437e 384(defun %free-static (type location)
385 (declare (ignore type location))
386 nil)