1 ;; Common Lisp bindings for GTK+ v2.0
2 ;; Copyright (C) 2000 Espen S. Johnsen <esj@stud.cs.uit.no>
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.
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.
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
18 ;; $Id: proxy.lisp,v 1.10 2004-11-03 16:18:16 espen Exp $
23 '(pcl::initialize-internal-slot-functions
24 pcl::compute-effective-slot-definition-initargs
25 pcl::compute-slot-accessor-info
26 pcl::reader-function pcl::writer-function pcl::boundp-function))
28 ;;;; Superclass for all metaclasses implementing some sort of virtual slots
30 (eval-when (:compile-toplevel :load-toplevel :execute)
31 (defclass virtual-slot-class (standard-class)
34 (defclass direct-virtual-slot-definition (standard-direct-slot-definition)
35 ((setter :reader slot-definition-setter :initarg :setter)
36 (getter :reader slot-definition-getter :initarg :getter)
37 (boundp :reader slot-definition-boundp :initarg :boundp)))
39 (defclass effective-virtual-slot-definition (standard-effective-slot-definition)
40 ((setter :reader slot-definition-setter :initarg :setter)
41 (getter :reader slot-definition-getter :initarg :getter)
42 (boundp :reader slot-definition-boundp :initarg :boundp)))
44 (defun most-specific-slot-value (instances slot &optional default)
45 (let ((object (find-if
47 (and (slot-exists-p ob slot) (slot-boundp ob slot)))
50 (slot-value object slot)
56 (defmethod direct-slot-definition-class ((class virtual-slot-class) &rest initargs)
57 (if (eq (getf initargs :allocation) :virtual)
58 (find-class 'direct-virtual-slot-definition)
61 (defmethod effective-slot-definition-class ((class virtual-slot-class) &rest initargs)
62 (if (eq (getf initargs :allocation) :virtual)
63 (find-class 'effective-virtual-slot-definition)
67 (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition))
68 (with-slots (getter setter boundp) slotd
69 (unless (slot-boundp slotd 'reader-function)
71 (slot-value slotd 'reader-function)
74 (null #'(lambda (object)
75 (declare (ignore object))
76 (error "Can't read slot: ~A" (slot-definition-name slotd))))
77 (symbol #'(lambda (object)
78 (funcall getter object)))
79 (string (let ((reader (mkbinding-late getter
80 (slot-definition-type slotd) 'pointer)))
81 (setf (slot-value slotd 'reader-function)
83 (funcall reader (proxy-location object)))))))))
85 (unless (slot-boundp slotd 'writer-function)
87 (slot-value slotd 'writer-function)
90 (null #'(lambda (object)
91 (declare (ignore object))
92 (error "Can't set slot: ~A" (slot-definition-name slotd))))
93 ((or symbol cons) #'(lambda (value object)
94 (funcall (fdefinition setter) value object)))
96 (let ((writer (mkbinding-late setter 'nil 'pointer
97 (slot-definition-type slotd))))
98 (setf (slot-value slotd 'writer-function)
99 #'(lambda (value object)
100 (funcall writer (proxy-location object) value))))))))
102 (unless (slot-boundp slotd 'boundp-function)
104 (slot-value slotd 'boundp-function)
107 (null #'(lambda (object)
108 (declare (ignore object))
110 (symbol #'(lambda (object)
111 (funcall boundp object)))))))
112 (initialize-internal-slot-gfs (slot-definition-name slotd)))
116 (defmethod compute-slot-accessor-info ((slotd effective-virtual-slot-definition)
120 (defmethod compute-effective-slot-definition-initargs ((class virtual-slot-class) direct-slotds)
121 (if (eq (most-specific-slot-value direct-slotds 'allocation) :virtual)
123 (list :getter (most-specific-slot-value direct-slotds 'getter)
124 :setter (most-specific-slot-value direct-slotds 'setter)
125 :boundp (most-specific-slot-value direct-slotds 'boundp))
130 (defmethod slot-value-using-class
131 ((class virtual-slot-class) (object standard-object)
132 (slotd effective-virtual-slot-definition))
133 (if (funcall (slot-value slotd 'boundp-function) object)
134 (funcall (slot-value slotd 'reader-function) object)
135 (slot-unbound class object (slot-definition-name slotd))))
137 (defmethod slot-boundp-using-class
138 ((class virtual-slot-class) (object standard-object)
139 (slotd effective-virtual-slot-definition))
140 (funcall (slot-value slotd 'boundp-function) object))
142 (defmethod (setf slot-value-using-class)
143 (value (class virtual-slot-class) (object standard-object)
144 (slotd effective-virtual-slot-definition))
145 (funcall (slot-value slotd 'writer-function) value object))
148 (defmethod validate-superclass
149 ((class virtual-slot-class) (super standard-class))
155 (internal *instance-cache*)
156 (defvar *instance-cache* (make-hash-table :test #'eql))
158 (defun cache-instance (instance)
160 (gethash (system:sap-int (proxy-location instance)) *instance-cache*)
161 (ext:make-weak-pointer instance)))
163 (defun find-cached-instance (location)
164 (let ((ref (gethash (system:sap-int location) *instance-cache*)))
166 (ext:weak-pointer-value ref))))
168 (defun instance-cached-p (location)
169 (gethash (system:sap-int location) *instance-cache*))
171 (defun remove-cached-instance (location)
172 (remhash (system:sap-int location) *instance-cache*))
176 ;;;; Proxy for alien instances
178 (eval-when (:compile-toplevel :load-toplevel :execute)
180 ((location :reader proxy-location :type system-area-pointer)))
182 (defgeneric initialize-proxy (object &rest initargs))
183 (defgeneric instance-finalizer (object)))
185 (defmethod print-object ((instance proxy) stream)
186 (print-unreadable-object (instance stream :type t :identity nil)
187 (format stream "at 0x~X" (sap-int (proxy-location instance)))))
190 (defmethod initialize-instance :after ((instance proxy)
192 (declare (ignore initargs))
193 (cache-instance instance)
194 (ext:finalize instance (instance-finalizer instance)))
196 (defmethod initialize-proxy ((instance proxy)
197 &rest initargs &key location weak-ref)
198 (declare (ignore initargs))
200 (slot-value instance 'location)
203 (proxy-class-copy (class-of instance))
204 (type-of instance) location)
206 (cache-instance instance)
207 (ext:finalize instance (instance-finalizer instance)))
209 (defmethod instance-finalizer ((instance proxy))
210 (let ((class (class-of instance))
211 (type (type-of instance))
212 (location (proxy-location instance)))
213 (declare (type symbol type) (type system-area-pointer location))
214 (let ((free (proxy-class-free class)))
216 (when (instance-cached-p location)
217 (remove-cached-instance location)
218 (funcall free type location))))))
221 (deftype-method translate-type-spec proxy (type-spec)
222 (declare (ignore type-spec))
223 (translate-type-spec 'pointer))
225 (deftype-method size-of proxy (type-spec)
226 (declare (ignore type-spec))
229 (deftype-method translate-from-alien
230 proxy (type-spec location &optional weak-ref)
231 `(let ((location ,location))
232 (unless (null-pointer-p location)
233 (ensure-proxy-instance ',type-spec location ,weak-ref))))
235 (deftype-method translate-to-alien
236 proxy (type-spec instance &optional weak-ref)
238 `(proxy-location ,instance)
239 (let ((copy (proxy-class-copy (find-class type-spec))))
241 `(,copy ',type-spec (proxy-location ,instance))
242 `(funcall ',copy ',type-spec (proxy-location ,instance))))))
244 (deftype-method unreference-alien proxy (type-spec location)
245 (let ((free (proxy-class-free (find-class type-spec))))
247 `(,free ',type-spec ,location)
248 `(funcall ',free ',type-spec ,location))))
251 ;;;; Metaclass used for subclasses of proxy
253 (eval-when (:compile-toplevel :load-toplevel :execute)
254 (defclass proxy-class (virtual-slot-class)
255 ((size :reader proxy-class-size)
256 (copy :reader proxy-class-copy)
257 (free :reader proxy-class-free)))
259 (defclass direct-alien-slot-definition (direct-virtual-slot-definition)
260 ((allocation :initform :alien)
261 (offset :reader slot-definition-offset :initarg :offset)))
263 (defclass effective-alien-slot-definition (effective-virtual-slot-definition)
264 ((offset :reader slot-definition-offset :initarg :offset)))
267 (defmethod most-specific-proxy-superclass ((class proxy-class))
270 (subtypep (class-name class) 'proxy))
271 (cdr (compute-class-precedence-list class))))
273 (defmethod direct-proxy-superclass ((class proxy-class))
276 (subtypep (class-name class) 'proxy))
277 (class-direct-superclasses class)))
279 (defmethod shared-initialize ((class proxy-class) names
280 &rest initargs &key size copy free)
281 (declare (ignore initargs))
284 (size (setf (slot-value class 'size) (first size)))
285 ((slot-boundp class 'size) (slot-makunbound class 'size)))
287 (copy (setf (slot-value class 'copy) (first copy)))
288 ((slot-boundp class 'copy) (slot-makunbound class 'copy)))
290 (free (setf (slot-value class 'free) (first free)))
291 ((slot-boundp class 'free) (slot-makunbound class 'free))))
293 (defmethod shared-initialize :after ((class proxy-class) names &rest initargs)
294 (let ((super (most-specific-proxy-superclass class)))
295 (unless (or (not super) (eq super (find-class 'proxy)))
296 (unless (or (slot-boundp class 'copy) (not (slot-boundp super 'copy)))
297 (setf (slot-value class 'copy) (proxy-class-copy super)))
298 (unless (or (slot-boundp class 'free) (not (slot-boundp super 'free)))
299 (setf (slot-value class 'free) (proxy-class-free super))))))
301 (defmethod direct-slot-definition-class ((class proxy-class) &rest initargs)
302 (case (getf initargs :allocation)
303 ((nil :alien) (find-class 'direct-alien-slot-definition))
304 (t (call-next-method))))
306 (defmethod effective-slot-definition-class ((class proxy-class) &rest initargs)
307 (case (getf initargs :allocation)
308 (:alien (find-class 'effective-alien-slot-definition))
309 (t (call-next-method))))
312 (defmethod compute-effective-slot-definition-initargs ((class proxy-class) direct-slotds)
313 (if (eq (most-specific-slot-value direct-slotds 'allocation) :alien)
315 (list :offset (most-specific-slot-value direct-slotds 'offset))
320 (defmethod initialize-internal-slot-functions ((slotd effective-alien-slot-definition))
321 (with-slots (offset) slotd
322 (let* ((type (slot-definition-type slotd))
323 (reader (intern-reader-function type))
324 (writer (intern-writer-function type))
325 (destroy (intern-destroy-function type)))
326 (unless (slot-boundp slotd 'reader-function)
328 (slot-value slotd 'reader-function)
330 (funcall reader (proxy-location object) offset))))
332 (unless (slot-boundp slotd 'writer-function)
334 (slot-value slotd 'writer-function)
335 #'(lambda (value object)
336 (let ((location (proxy-location object)))
337 (funcall destroy location offset)
338 (funcall writer value location offset)))))
340 (unless (slot-boundp slotd 'boundp-function)
342 (slot-value slotd 'boundp-function)
344 (declare (ignore object))
349 ;; TODO: call some C code to detect this a compile time
350 (defconstant +struct-alignmen+ 4)
352 (defmethod compute-slots ((class proxy-class))
353 ;; This stuff should really go somewhere else
355 with offset = (proxy-class-size (most-specific-proxy-superclass class))
357 for slotd in (class-direct-slots class)
358 when (eq (slot-definition-allocation slotd) :alien)
359 do (if (not (slot-boundp slotd 'offset))
360 (setf (slot-value slotd 'offset) offset)
361 (setq offset (slot-value slotd 'offset)))
363 (incf offset (size-of (slot-definition-type slotd)))
364 (incf offset (mod offset +struct-alignmen+))
365 (setq size (max size offset))
367 finally (unless (slot-boundp class 'size)
368 (setf (slot-value class 'size) size)))
372 (defmethod validate-superclass ((class proxy-class) (super standard-class))
373 (subtypep (class-name super) 'proxy))
375 (defmethod proxy-class-size (class)
376 (declare (ignore class))
380 (defgeneric make-proxy-instance (class location weak-ref
381 &rest initargs &key));)
383 (defmethod make-proxy-instance ((class symbol) location weak-ref
385 (apply #'make-proxy-instance (find-class class) location weak-ref initargs))
387 (defmethod make-proxy-instance ((class proxy-class) location weak-ref
389 (let ((instance (allocate-instance class)))
392 instance :location location :weak-ref weak-ref initargs)
395 (defun ensure-proxy-instance (class location weak-ref &rest initargs)
397 (find-cached-instance location)
398 (apply #'make-proxy-instance class location weak-ref initargs)))
402 ;;;; Superclasses for wrapping of C structures
404 (eval-when (:compile-toplevel :load-toplevel :execute)
405 (defclass struct (proxy)
407 (:metaclass proxy-class)
409 (:free %free-struct)))
411 (defmethod initialize-instance ((structure struct) &rest initargs)
412 (declare (ignore initargs))
414 (slot-value structure 'location)
415 (allocate-memory (proxy-class-size (class-of structure))))
419 (defun %copy-struct (type location)
420 (copy-memory location (proxy-class-size (find-class type))))
422 (defun %free-struct (type location)
423 (declare (ignore type))
424 (deallocate-memory location))
427 ;(eval-when (:compile-toplevel :load-toplevel :execute)
428 (defclass static (struct)
430 (:metaclass proxy-class)
432 (:free %free-static));)
434 (defun %copy-static (type location)
435 (declare (ignore type))
438 (defun %free-static (type location)
439 (declare (ignore type location))