1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 2000-2006 Espen S. Johnsen <espen@users.sf.net>
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:
12 ;; The above copyright notice and this permission notice shall be
13 ;; included in all copies or substantial portions of the Software.
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.
23 ;; $Id: proxy.lisp,v 1.7 2007-04-06 14:29:42 espen Exp $
30 (defvar *instance-cache* (make-hash-table :test #'eql))
32 (defun cache-instance (instance &optional (weak-ref t))
34 (gethash (pointer-address (foreign-location instance)) *instance-cache*)
36 (make-weak-pointer instance)
39 (defun find-cached-instance (location)
40 (let ((ref (gethash (pointer-address location) *instance-cache*)))
42 (if (weak-pointer-p ref)
43 (weak-pointer-value ref)
46 (defun instance-cached-p (location)
47 (gethash (pointer-address location) *instance-cache*))
49 (defun remove-cached-instance (location)
50 (remhash (pointer-address location) *instance-cache*))
53 (defun list-cached-instances ()
55 (maphash #'(lambda (location ref)
56 (declare (ignore location))
61 ;; Instances that gets invalidated tend to be short lived, but created
62 ;; in large numbers. So we're keeping them in a hash table to be able
63 ;; to reuse them (and thus reduce consing)
64 (defvar *invalidated-instance-cache* (make-hash-table :test #'eql))
66 (defun cache-invalidated-instance (instance)
68 (gethash (class-of instance) *invalidated-instance-cache*)))
70 (defun find-invalidated-instance (class)
71 (when (gethash class *invalidated-instance-cache*)
72 (pop (gethash class *invalidated-instance-cache*))))
74 (defun list-invalidated-instances ()
76 (maphash #'(lambda (location ref)
77 (declare (ignore location))
79 *invalidated-instance-cache*)
84 ;;;; Proxy for alien instances
86 #?(or (sbcl>= 0 9 17) (featurep :clisp))
87 (defvar *foreign-instance-locations*
88 (make-hash-table #+clisp :weak #+sbcl :weakness :key))
91 (eval-when (:compile-toplevel :load-toplevel :execute)
92 (defclass proxy (virtual-slots-object)
93 (#?-(or (sbcl>= 0 9 17) (featurep :clisp))(%location :special t :type pointer))
94 (:metaclass virtual-slots-class)))
96 (defgeneric instance-finalizer (instance))
97 (defgeneric reference-function (class))
98 (defgeneric unreference-function (class))
99 (defgeneric invalidate-instance (instance &optional finalize-p))
100 (defgeneric allocate-foreign (object &key &allow-other-keys))
102 #?-(or (sbcl>= 0 9 17) (featurep :clisp))
104 (defun foreign-location (instance)
105 (slot-value instance '%location))
107 (defun (setf foreign-location) (location instance)
108 (setf (slot-value instance '%location) location))
110 (defun proxy-valid-p (instance)
111 (slot-boundp instance '%location)))
113 #?(or (sbcl>= 0 9 17) (featurep :clisp))
115 (defun foreign-location (instance)
116 (gethash instance *foreign-instance-locations*))
118 (defun (setf foreign-location) (location instance)
119 (setf (gethash instance *foreign-instance-locations*) location))
121 (defun proxy-valid-p (instance)
122 (and (gethash instance *foreign-instance-locations*) t)))
125 (defmethod reference-function ((name symbol))
126 (reference-function (find-class name)))
128 (defmethod unreference-function ((name symbol))
129 (unreference-function (find-class name)))
131 (defmethod print-object ((instance proxy) stream)
132 (print-unreadable-object (instance stream :type t :identity nil)
133 (if (proxy-valid-p instance)
134 (format stream "at 0x~X" (pointer-address (foreign-location instance)))
135 (write-string "at \"unbound\"" stream))))
138 (defmethod initialize-instance :around ((instance proxy) &rest initargs &key &allow-other-keys)
140 (foreign-location instance)
141 (apply #'allocate-foreign instance initargs))
144 (cache-instance instance)
145 (finalize instance (instance-finalizer instance))))
147 (defmethod instance-finalizer :around ((instance proxy))
148 (let ((finalizer (call-next-method)))
149 (let ((location (foreign-location instance)))
152 (remove-cached-instance location)
156 (declare (ignore instance))
157 (remove-cached-instance location)
158 (funcall finalizer)))))
160 (defmethod instance-finalizer ((instance proxy))
161 (let ((location (foreign-location instance))
162 (unref (unreference-function (class-of instance))))
164 (funcall unref location))))
166 ;; FINALIZE-P should always be the same as the keyword argument
167 ;; :FINALZIE given to MAKE-PROXY-INSTANCE or non NIL if the proxy was
168 ;; created with MAKE-INSTANCE
169 (defmethod invalidate-instance ((instance proxy) &optional finalize-p)
170 (remove-cached-instance (foreign-location instance))
174 (funcall (instance-finalizer instance)))
175 #?-(sbcl>= 0 9 17)(slot-makunbound instance '%location)
176 #?(sbcl>= 0 9 17)(remhash instance *foreign-instance-locations*)
177 (cancel-finalization instance))
178 ;; We can't cache invalidated instances in CLISP beacuse it is
179 ;; not possible to cancel finalization
180 #-clisp(cache-invalidated-instance instance))
183 ;;;; Metaclass used for subclasses of proxy
185 (eval-when (:compile-toplevel :load-toplevel :execute)
186 (defclass proxy-class (virtual-slots-class)
187 ((size :accessor foreign-size)
188 (packed :reader foreign-slots-packed-p)
189 (ref :reader reference-function)
190 (unref :reader unreference-function)))
192 (defclass direct-alien-slot-definition (direct-virtual-slot-definition)
193 ((offset :reader slot-definition-offset :initarg :offset))
194 (:default-initargs :allocation :alien))
196 (defclass effective-alien-slot-definition (effective-virtual-slot-definition)
197 ((offset :reader slot-definition-offset :initarg :offset)))
199 (defclass direct-virtual-alien-slot-definition (direct-virtual-slot-definition)
202 (defclass effective-virtual-alien-slot-definition (effective-virtual-slot-definition)
205 (defgeneric foreign-size-p (class))
206 (defgeneric most-specific-proxy-superclass (class))
207 (defgeneric direct-proxy-superclass (class))
209 (defmethod foreign-size-p ((class proxy-class))
210 (slot-boundp class 'size))
212 (defmethod most-specific-proxy-superclass ((class proxy-class))
215 (subtypep (class-name class) 'proxy))
216 (cdr (compute-class-precedence-list class))))
218 (defmethod direct-proxy-superclass ((class proxy-class))
221 (subtypep (class-name class) 'proxy))
222 (class-direct-superclasses class)))
224 (defmethod shared-initialize ((class proxy-class) names
225 &key size packed ref unref)
226 (declare (ignore names))
228 (size (setf (slot-value class 'size) (first size)))
229 ((slot-boundp class 'size) (slot-makunbound class 'size)))
230 (setf (slot-value class 'packed) (first packed))
232 (setf (slot-value class 'ref) (first ref)))
234 (setf (slot-value class 'unref) (first unref)))
237 (defmethod direct-slot-definition-class ((class proxy-class) &rest initargs)
238 (case (getf initargs :allocation)
239 (:alien (find-class 'direct-alien-slot-definition))
240 (:virtual (find-class 'direct-virtual-alien-slot-definition))
241 (t (call-next-method))))
243 (defmethod effective-slot-definition-class ((class proxy-class) &rest initargs)
244 (case (getf initargs :allocation)
245 (:alien (find-class 'effective-alien-slot-definition))
246 (:virtual (find-class 'effective-virtual-alien-slot-definition))
247 (t (call-next-method))))
250 (defmethod compute-effective-slot-definition-initargs ((class proxy-class) direct-slotds)
251 (if (eq (slot-definition-allocation (first direct-slotds)) :alien)
253 (list :offset (most-specific-slot-value direct-slotds 'offset))
257 (defmethod slot-readable-p ((slotd effective-alien-slot-definition))
258 (declare (ignore slotd))
261 (defmethod compute-slot-reader-function ((slotd effective-alien-slot-definition) &optional signal-unbound-p)
262 (declare (ignore signal-unbound-p))
263 (let* ((type (slot-definition-type slotd))
264 (offset (slot-definition-offset slotd))
265 (reader (reader-function type)))
267 (funcall reader (foreign-location object) offset))))
269 (defmethod slot-writable-p ((slotd effective-alien-slot-definition))
270 (declare (ignore slotd))
273 (defmethod compute-slot-writer-function ((slotd effective-alien-slot-definition))
274 (let* ((type (slot-definition-type slotd))
275 (offset (slot-definition-offset slotd))
276 (writer (writer-function type))
277 (destroy (destroy-function type)))
278 #'(lambda (value object)
279 (let ((location (foreign-location object)))
280 (funcall destroy location offset) ; destroy old value
281 (funcall writer value location offset))
284 (defmethod compute-slot-reader-function ((slotd effective-virtual-alien-slot-definition) &optional signal-unbound-p)
285 (declare (ignore signal-unbound-p))
286 (if (and (slot-boundp slotd 'getter) (stringp (slot-definition-getter slotd)))
287 (let ((getter (slot-definition-getter slotd))
288 (type (slot-definition-type slotd))
292 (setq reader (mkbinding getter type 'pointer)))
293 (funcall reader (foreign-location object))))
296 (defmethod compute-slot-writer-function ((slotd effective-virtual-alien-slot-definition))
297 (if (and (slot-boundp slotd 'setter) (stringp (slot-definition-setter slotd)))
298 (let ((setter (slot-definition-setter slotd))
299 (type (slot-definition-type slotd))
301 #'(lambda (value object)
303 (setq writer (mkbinding setter nil 'pointer type)))
304 (funcall writer (foreign-location object) value)))
307 (defun adjust-offset (offset type &optional packed-p)
308 (let ((alignment (type-alignment type)))
309 (if (or packed-p (zerop (mod offset alignment)))
311 (+ offset (- alignment (mod offset alignment))))))
313 (defmethod compute-slots ((class proxy-class))
314 (let ((alien-slots (remove-if-not
315 #'(lambda (allocation) (eq allocation :alien))
316 (class-direct-slots class)
317 :key #'slot-definition-allocation)))
320 with packed-p = (foreign-slots-packed-p class)
321 for slotd in alien-slots
322 as offset = (adjust-offset
323 (foreign-size (most-specific-proxy-superclass class))
324 (slot-definition-type slotd)
326 then (adjust-offset offset (slot-definition-type slotd) packed-p)
327 do (if (slot-boundp slotd 'offset)
328 (setf offset (slot-value slotd 'offset))
329 (setf (slot-value slotd 'offset) offset))
330 (incf offset (size-of (slot-definition-type slotd))))))
333 (defmethod validate-superclass ((class proxy-class) (super standard-class))
334 (subtypep (class-name super) 'proxy))
336 (defmethod foreign-size ((class-name symbol))
337 (foreign-size (find-class class-name))))
339 (defmethod foreign-size ((object proxy))
340 (foreign-size (class-of object)))
342 (define-type-method alien-type ((type proxy))
343 (declare (ignore type))
344 (alien-type 'pointer))
346 (define-type-method size-of ((type proxy) &key inlined)
347 (assert-not-inlined type inlined)
350 (define-type-method type-alignment ((type proxy) &key inlined)
351 (assert-not-inlined type inlined)
352 (type-alignment 'pointer))
354 (define-type-method from-alien-form ((type proxy) form &key (ref :free))
355 (let ((class (type-expand type)))
357 (:free `(ensure-proxy-instance ',class ,form :reference nil))
358 (:copy `(ensure-proxy-instance ',class ,form))
359 ((:static :temp) `(ensure-proxy-instance ',class ,form
360 :reference nil :finalize nil)))))
362 (define-type-method from-alien-function ((type proxy) &key (ref :free))
363 (let ((class (type-expand type)))
367 (ensure-proxy-instance class location :reference nil)))
370 (ensure-proxy-instance class location)))
373 (ensure-proxy-instance class location :reference nil :finalize nil))))))
375 (define-type-method to-alien-form ((type proxy) instance &optional copy-p)
377 (let* ((class (type-expand type))
378 (ref (reference-function class)))
380 `(,ref (foreign-location ,instance))
381 `(funcall (reference-function ',class)
382 (foreign-location ,instance))))
383 `(foreign-location ,instance)))
385 (define-type-method to-alien-function ((type proxy) &optional copy-p)
387 (let ((ref (reference-function (type-expand type))))
389 (funcall ref (foreign-location instance))))
392 (define-type-method writer-function ((type proxy) &key temp inlined)
393 (assert-not-inlined type inlined)
395 #'(lambda (instance location &optional (offset 0))
396 (assert (null-pointer-p (ref-pointer location offset)))
397 (setf (ref-pointer location offset) (foreign-location instance)))
398 (let ((ref (reference-function (type-expand type))))
399 #'(lambda (instance location &optional (offset 0))
400 (assert (null-pointer-p (ref-pointer location offset)))
402 (ref-pointer location offset)
403 (funcall ref (foreign-location instance)))))))
405 (define-type-method reader-function ((type proxy) &key (ref :read) inlined)
406 (assert-not-inlined type inlined)
407 (let ((class (type-expand type)))
410 #'(lambda (location &optional (offset 0))
411 (let ((instance (ref-pointer location offset)))
412 (unless (null-pointer-p instance)
413 (ensure-proxy-instance class instance)))))
415 #'(lambda (location &optional (offset 0))
416 (let ((instance (ref-pointer location offset)))
417 (unless (null-pointer-p instance)
418 (ensure-proxy-instance class instance
419 :reference nil :finalize nil)))))
421 #'(lambda (location &optional (offset 0))
422 (let ((instance (ref-pointer location offset)))
423 (unless (null-pointer-p instance)
425 (ensure-proxy-instance class instance :reference nil)
426 (setf (ref-pointer location offset) (make-pointer 0))))))))))
428 (define-type-method destroy-function ((type proxy) &key temp inlined)
429 (assert-not-inlined type inlined)
431 #'(lambda (location &optional (offset 0))
432 (setf (ref-pointer location offset) (make-pointer 0)))
433 (let ((unref (unreference-function (type-expand type))))
434 #'(lambda (location &optional (offset 0))
435 (unless (null-pointer-p (ref-pointer location offset))
436 (funcall unref (ref-pointer location offset))
437 (setf (ref-pointer location offset) (make-pointer 0)))))))
439 (define-type-method copy-function ((type proxy) &key inlined)
440 (assert-not-inlined type inlined)
441 (let ((ref (reference-function (type-expand type))))
442 #'(lambda (from to &optional (offset 0))
443 (let ((instance (ref-pointer from offset)))
444 (unless (null-pointer-p instance)
445 (funcall ref instance))
446 (setf (ref-pointer to offset) instance)))))
448 (define-type-method unbound-value ((type proxy))
449 (declare (ignore type))
452 (defun ensure-proxy-instance (class location &rest initargs)
453 "Returns a proxy object representing the foreign object at the give
454 location. If an existing proxy object is not found,
455 MAKE-PROXY-INSTANCE is called to create a new one. A second return
456 value indicates whether a new proxy was created or not."
457 (unless (null-pointer-p location)
459 #-debug-ref-counting(find-cached-instance location)
461 (let ((instance (find-cached-instance location)))
463 (format t "Object found in cache: ~A~%" instance)
466 (apply #'make-proxy-instance class location initargs)
469 (defgeneric make-proxy-instance (class location &key reference finalize)
470 (:documentation "Creates a new proxy object representing the foreign
471 object at the give location."))
473 (defmethod make-proxy-instance ((class symbol) location &rest initargs)
474 (apply #'make-proxy-instance (find-class class) location initargs))
476 (defmethod make-proxy-instance ((class proxy-class) location
477 &key (reference t) (finalize t))
480 (find-invalidated-instance class)
481 (allocate-instance class))))
482 (setf (foreign-location instance)
484 (funcall (reference-function class) location)
488 (instance-finalizer instance)
489 ;; We still need to remove the instance from the cache even if we
490 ;; don't do normal finalization
491 (let ((location (foreign-location instance)))
494 (remove-cached-instance location))
497 (declare (ignore instance))
498 (remove-cached-instance location)))))
499 (cache-instance instance)
502 ;;;; Superclass for ref-counted objects
504 (defclass ref-counted-object (proxy)
506 (:metaclass proxy-class))
508 (define-type-method from-alien-form ((type ref-counted-object) form
510 (call-next-method type form :ref ref))
512 (define-type-method from-alien-function ((type ref-counted-object)
514 (call-next-method type :ref ref))
517 ;;;; Superclasses for wrapping of C structures
519 (defclass struct (proxy)
521 (:metaclass proxy-class)
524 (defmethod allocate-foreign ((struct struct) &rest initargs)
525 (declare (ignore initargs))
526 (let ((size (foreign-size (class-of struct))))
528 (error "~A has zero size" (class-of struct))
529 (allocate-memory size))))
532 ;;;; Metaclasses used for subclasses of struct
534 (defclass struct-class (proxy-class)
537 (defmethod shared-initialize ((class struct-class) names &rest initargs)
538 (declare (ignore names initargs))
540 (let ((offsets nil) (copy-functions nil) (destroy-functions nil))
541 (flet ((initialize-functions ()
543 for slotd in (class-slots class)
544 as type = (slot-definition-type slotd)
545 when (eq (slot-definition-allocation slotd) :alien)
546 do (push (slot-definition-offset slotd) offsets)
547 (push (copy-function type) copy-functions)
548 (push (destroy-function type) destroy-functions))))
549 (unless (slot-boundp class 'ref)
551 (slot-value class 'ref)
552 #'(lambda (from &optional (to (allocate-memory (foreign-size class))))
553 (assert (not (null-pointer-p from)))
555 (initialize-functions))
557 for offset in offsets
558 for copy in copy-functions
559 do (funcall copy from to offset))
561 (unless (slot-boundp class 'unref)
562 (setf (slot-value class 'unref)
563 #'(lambda (location &optional inlined-p)
564 (assert (not (null-pointer-p location)))
566 (initialize-functions))
568 for offset in offsets
569 for destroy in destroy-functions
570 do (funcall destroy location offset))
572 (deallocate-memory location))))))))
575 (defmethod direct-slot-definition-class ((class struct-class) &rest initargs)
576 (if (not (getf initargs :allocation))
577 (find-class 'direct-alien-slot-definition)
581 (defmethod compute-slots :around ((class struct-class))
582 (let ((slots (call-next-method)))
584 #?-(or (sbcl>= 0 9 8) (featurep :clisp))(class-finalized-p class)
585 (not (slot-boundp class 'size)))
586 (setf (slot-value class 'size)
590 when (eq (slot-definition-allocation slotd) :alien)
592 (slot-definition-offset slotd)
593 (size-of (slot-definition-type slotd))))
597 (define-type-method callback-wrapper ((type struct) var arg form)
598 (let ((class (type-expand type)))
599 `(let ((,var (ensure-proxy-instance ',class ,arg :finalize nil)))
602 (invalidate-instance ,var)))))
604 (define-type-method size-of ((type struct) &key inlined)
609 (define-type-method type-alignment ((type struct) &key inlined)
611 (let ((slot1 (find-if
613 (eq (slot-definition-allocation slotd) :alien))
614 (class-slots (find-class type)))))
615 (type-alignment (slot-definition-type slot1)))
616 (type-alignment 'pointer)))
618 (define-type-method writer-function ((type struct) &key temp inlined)
621 (let ((size (size-of type :inlined t)))
622 #'(lambda (instance location &optional (offset 0))
624 (foreign-location instance) size
625 (pointer+ location offset))))
626 (let ((ref (reference-function (type-expand type))))
627 #'(lambda (instance location &optional (offset 0))
629 (foreign-location instance)
630 (pointer+ location offset)))))
633 (define-type-method reader-function ((type struct) &key (ref :read) inlined)
635 (let ((class (type-expand type))
636 (size (size-of type :inlined t)))
639 #'(lambda (location &optional (offset 0))
640 (ensure-proxy-instance class (pointer+ location offset))))
642 #'(lambda (location &optional (offset 0))
643 (ensure-proxy-instance class (pointer+ location offset)
644 :reference nil :finalize nil)))
646 #'(lambda (location &optional (offset 0))
648 (ensure-proxy-instance class
649 (copy-memory (pointer+ location offset) size)
651 (clear-memory (pointer+ location offset) size))))))
654 (define-type-method destroy-function ((type struct) &key temp inlined)
656 (let ((size (size-of type :inlined t)))
658 #'(lambda (location &optional (offset 0))
659 (clear-memory (pointer+ location offset) size))
660 (let ((unref (unreference-function (type-expand type))))
661 #'(lambda (location &optional (offset 0))
662 (funcall unref (pointer+ location offset) t)))))
665 (define-type-method copy-function ((type struct) &key inlined)
667 (let ((ref (reference-function (type-expand type))))
668 #'(lambda (from to &optional (offset 0))
669 (funcall ref (pointer+ from offset) (pointer+ to offset))))