1 ;; Common Lisp bindings for GTK+ v2.x
2 ;; Copyright 2000-2005 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.37 2006-02-26 16:12:25 espen Exp $
27 ;;;; Superclass for all metaclasses implementing some sort of virtual slots
29 (eval-when (:compile-toplevel :load-toplevel :execute)
30 (defclass virtual-slots-class (standard-class)
33 (defclass direct-virtual-slot-definition (standard-direct-slot-definition)
34 ((setter :reader slot-definition-setter :initarg :setter)
35 (getter :reader slot-definition-getter :initarg :getter)
36 (unbound :reader slot-definition-unbound :initarg :unbound)
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 (unbound :reader slot-definition-unbound :initarg :unbound)
43 (boundp :reader slot-definition-boundp :initarg :boundp)))
45 (defclass direct-special-slot-definition (standard-direct-slot-definition)
46 ((special :initarg :special :accessor slot-definition-special)))
48 (defclass effective-special-slot-definition (standard-effective-slot-definition)
49 ((special :initarg :special :accessor slot-definition-special))))
51 (defvar *unbound-marker* (gensym "UNBOUND-MARKER-"))
53 (defun most-specific-slot-value (instances slot &optional (default *unbound-marker*))
54 (let ((object (find-if
56 (and (slot-exists-p ob slot) (slot-boundp ob slot)))
59 (slot-value object slot)
63 (defmethod direct-slot-definition-class ((class virtual-slots-class) &rest initargs)
65 ((eq (getf initargs :allocation) :virtual)
66 (find-class 'direct-virtual-slot-definition))
67 ((getf initargs :special)
68 (find-class 'direct-special-slot-definition))
69 (t (call-next-method))))
71 (defmethod effective-slot-definition-class ((class virtual-slots-class) &rest initargs)
73 ((eq (getf initargs :allocation) :virtual)
74 (find-class 'effective-virtual-slot-definition))
75 ((getf initargs :special)
76 (find-class 'effective-special-slot-definition))
77 (t (call-next-method))))
80 (defmethod initialize-internal-slot-functions ((slotd effective-virtual-slot-definition))
81 (if (not (slot-boundp slotd 'getter))
83 (slot-value slotd 'reader-function)
85 (declare (ignore object))
86 (error "Slot is not readable: ~A" (slot-definition-name slotd)))
87 (slot-value slotd 'boundp-function)
88 #'(lambda (object) (declare (ignore object)) nil))
90 (let ((getter-function
91 (let ((getter (slot-value slotd 'getter)))
96 (funcall getter object)))
99 (setf (slot-value slotd 'reader-function)
104 (slot-definition-type slotd) 'pointer)))
105 (funcall reader (foreign-location object))))))))))
108 (slot-value slotd 'boundp-function)
110 ((slot-boundp slotd 'unbound)
111 (let ((unbound-value (slot-value slotd 'unbound)))
113 (not (eq (funcall getter-function object) unbound-value)))))
114 ((slot-boundp slotd 'boundp)
115 (let ((boundp (slot-value slotd 'boundp)))
118 (symbol #'(lambda (object)
119 (funcall boundp object)))
120 (string (let ((reader ()))
125 (slot-definition-type slotd) 'pointer)))
126 (funcall reader (foreign-location object))))))))
127 ((let ((unbound-value-method
128 (find-applicable-type-method 'unbound-value
129 (slot-definition-type slotd) nil)))
130 (when unbound-value-method
132 (funcall unbound-value-method (slot-definition-type slotd))))
134 (not (eq (funcall getter-function object) unbound-value)))))))
135 (#'(lambda (object) (declare (ignore object)) t))))
138 (slot-value slotd 'reader-function)
140 ((slot-boundp slotd 'unbound)
141 (let ((unbound (slot-value slotd 'unbound))
142 (slot-name (slot-definition-name slotd)))
144 (let ((value (funcall getter-function object)))
145 (if (eq value unbound)
146 (slot-unbound (class-of object) object slot-name)
148 ((slot-boundp slotd 'boundp)
149 (let ((boundp-function (slot-value slotd 'boundp-function)))
152 (funcall boundp-function object)
153 (funcall getter-function object)))))
154 ((let ((unbound-value-method
155 (find-applicable-type-method 'unbound-value
156 (slot-definition-type slotd) nil)))
157 (when unbound-value-method
159 (funcall unbound-value-method (slot-definition-type slotd)))
160 (slot-name (slot-definition-name slotd)))
162 (let ((value (funcall getter-function object)))
163 (if (eq value unbound-value)
164 (slot-unbound (class-of object) object slot-name)
166 (getter-function)))))
169 (slot-value slotd 'writer-function)
170 (if (not (slot-boundp slotd 'setter))
171 #'(lambda (value object)
172 (declare (ignore value object))
173 (error "Slot is not writable: ~A" (slot-definition-name slotd)))
174 (with-slots (setter) slotd
178 #'(lambda (value object)
179 (funcall (fdefinition setter) value object)))
183 (slot-value slotd 'writer-function)
184 #'(lambda (value object)
187 (mkbinding setter 'nil 'pointer
188 (slot-definition-type slotd))))
189 (funcall writer (foreign-location object) value)))))))))
191 #-sbcl>=0.9.8(initialize-internal-slot-gfs (slot-definition-name slotd)))
195 (defmethod compute-slot-accessor-info ((slotd effective-virtual-slot-definition) type gf)
198 (defmethod compute-effective-slot-definition-initargs ((class virtual-slots-class) direct-slotds)
199 (typecase (first direct-slotds)
200 (direct-virtual-slot-definition
202 (let ((getter (most-specific-slot-value direct-slotds 'getter)))
203 (unless (eq getter *unbound-marker*)
204 (setf (getf initargs :getter) getter)))
205 (let ((setter (most-specific-slot-value direct-slotds 'setter)))
206 (unless (eq setter *unbound-marker*)
207 (setf (getf initargs :setter) setter)))
208 (let ((unbound (most-specific-slot-value direct-slotds 'unbound)))
209 (unless (eq unbound *unbound-marker*)
210 (setf (getf initargs :unbound) unbound)))
211 (let ((boundp (most-specific-slot-value direct-slotds 'boundp)))
212 (unless (eq boundp *unbound-marker*)
213 (setf (getf initargs :boundp) boundp)))
214 ;; Need this to prevent type expansion in SBCL >= 0.9.8
215 (let ((type (most-specific-slot-value direct-slotds 'type)))
216 (unless (eq type *unbound-marker*)
217 (setf (getf initargs :type) type)))
218 (nconc initargs (call-next-method))))
219 (direct-special-slot-definition
220 (append '(:special t) (call-next-method)))
221 (t (call-next-method))))
224 (defmethod slot-value-using-class
225 ((class virtual-slots-class) (object standard-object)
226 (slotd effective-virtual-slot-definition))
227 (if (funcall (slot-value slotd 'boundp-function) object)
228 (funcall (slot-value slotd 'reader-function) object)
229 (slot-unbound class object (slot-definition-name slotd))))
231 (defmethod slot-boundp-using-class
232 ((class virtual-slots-class) (object standard-object)
233 (slotd effective-virtual-slot-definition))
234 (funcall (slot-value slotd 'boundp-function) object))
236 (defmethod (setf slot-value-using-class)
237 (value (class virtual-slots-class) (object standard-object)
238 (slotd effective-virtual-slot-definition))
239 (funcall (slot-value slotd 'writer-function) value object))
242 (defmethod validate-superclass
243 ((class virtual-slots-class) (super standard-class))
247 (defmethod slot-definition-special ((slotd standard-direct-slot-definition))
248 (declare (ignore slotd))
251 (defmethod slot-definition-special ((slotd standard-effective-slot-definition))
252 (declare (ignore slotd))
258 (defvar *instance-cache* (make-hash-table :test #'eql))
260 (defun cache-instance (instance &optional (weak-ref t))
262 (gethash (sap-int (foreign-location instance)) *instance-cache*)
264 (make-weak-pointer instance)
267 (defun find-cached-instance (location)
268 (let ((ref (gethash (sap-int location) *instance-cache*)))
270 (if (weak-pointer-p ref)
271 (weak-pointer-value ref)
274 (defun instance-cached-p (location)
275 (gethash (sap-int location) *instance-cache*))
277 (defun remove-cached-instance (location)
278 (remhash (sap-int location) *instance-cache*))
281 (defun list-cached-instances ()
282 (let ((instances ()))
283 (maphash #'(lambda (location ref)
284 (declare (ignore location))
285 (push ref instances))
289 ;; Instances that gets invalidated tend to be short lived, but created
290 ;; in large numbers. So we're keeping them in a hash table to be able
291 ;; to reuse them (and thus reduce consing)
292 (defvar *invalidated-instance-cache* (make-hash-table :test #'eql))
294 (defun cache-invalidated-instance (instance)
296 (gethash (class-of instance) *invalidated-instance-cache*)))
298 (defun find-invalidated-instance (class)
299 (when (gethash class *invalidated-instance-cache*)
300 (pop (gethash class *invalidated-instance-cache*))))
302 (defun list-invalidated-instances ()
303 (let ((instances ()))
304 (maphash #'(lambda (location ref)
305 (declare (ignore location))
306 (push ref instances))
307 *invalidated-instance-cache*)
312 ;;;; Proxy for alien instances
314 ;; TODO: add a ref-counted-proxy subclass
316 ((location :special t :type pointer))
317 (:metaclass virtual-slots-class))
319 (defgeneric instance-finalizer (object))
320 (defgeneric reference-foreign (class location))
321 (defgeneric unreference-foreign (class location))
322 (defgeneric invalidate-instance (object))
323 (defgeneric allocate-foreign (object &key &allow-other-keys))
325 (defun foreign-location (instance)
326 (slot-value instance 'location))
328 (defun (setf foreign-location) (location instance)
329 (setf (slot-value instance 'location) location))
331 (defun proxy-valid-p (instance)
332 (slot-boundp instance 'location))
334 (defmethod reference-foreign ((name symbol) location)
335 (reference-foreign (find-class name) location))
337 (defmethod unreference-foreign ((name symbol) location)
338 (unreference-foreign (find-class name) location))
340 (defmethod unreference-foreign :around ((class class) location)
341 (unless (null-pointer-p location)
344 (defmethod print-object ((instance proxy) stream)
345 (print-unreadable-object (instance stream :type t :identity nil)
346 (if (slot-boundp instance 'location)
347 (format stream "at 0x~X" (sap-int (foreign-location instance)))
348 (write-string "at <unbound>" stream))))
350 (defmethod initialize-instance :around ((instance proxy) &rest initargs &key &allow-other-keys)
352 (foreign-location instance)
353 (apply #'allocate-foreign instance initargs))
356 (cache-instance instance)
357 (finalize instance (instance-finalizer instance))))
359 (defmethod instance-finalizer ((instance proxy))
360 (let ((location (foreign-location instance))
361 (class (class-of instance)))
362 ;; (unless (find-method #'unreference-foreign nil (list (class-of class) t) nil)
363 ;; (error "No matching method for UNREFERENCE-INSTANCE when called with class ~A" class))
365 (remove-cached-instance location)
366 (unreference-foreign class location))))
368 ;; Any reference to the foreign object the instance may have held
369 ;; should be released before this method is invoked
370 (defmethod invalidate-instance ((instance proxy))
371 (remove-cached-instance (foreign-location instance))
372 (slot-makunbound instance 'location)
373 (cancel-finalization instance)
374 (cache-invalidated-instance instance))
377 ;;;; Metaclass used for subclasses of proxy
379 (defgeneric most-specific-proxy-superclass (class))
380 (defgeneric direct-proxy-superclass (class))
383 (eval-when (:compile-toplevel :load-toplevel :execute)
384 (defclass proxy-class (virtual-slots-class)
385 ((size :reader foreign-size)))
387 (defclass direct-alien-slot-definition (direct-virtual-slot-definition)
388 ((offset :reader slot-definition-offset :initarg :offset))
389 (:default-initargs :allocation :alien))
391 (defclass effective-alien-slot-definition (effective-virtual-slot-definition)
392 ((offset :reader slot-definition-offset :initarg :offset)))
394 (defmethod most-specific-proxy-superclass ((class proxy-class))
397 (subtypep (class-name class) 'proxy))
398 (cdr (compute-class-precedence-list class))))
400 (defmethod direct-proxy-superclass ((class proxy-class))
403 (subtypep (class-name class) 'proxy))
404 (class-direct-superclasses class)))
406 (defmethod shared-initialize ((class proxy-class) names &key size)
409 (size (setf (slot-value class 'size) (first size)))
410 ((slot-boundp class 'size) (slot-makunbound class 'size))))
412 (defmethod direct-slot-definition-class ((class proxy-class) &rest initargs)
413 (case (getf initargs :allocation)
414 (:alien (find-class 'direct-alien-slot-definition))
415 (t (call-next-method))))
417 (defmethod effective-slot-definition-class ((class proxy-class) &rest initargs)
418 (case (getf initargs :allocation)
419 (:alien (find-class 'effective-alien-slot-definition))
420 (t (call-next-method))))
423 (defmethod compute-effective-slot-definition-initargs ((class proxy-class) direct-slotds)
424 (if (eq (slot-definition-allocation (first direct-slotds)) :alien)
426 (list :offset (most-specific-slot-value direct-slotds 'offset))
431 (defmethod initialize-internal-slot-functions ((slotd effective-alien-slot-definition))
432 (with-slots (offset) slotd
433 (let ((type (slot-definition-type slotd)))
434 (unless (slot-boundp slotd 'getter)
435 (let ((reader (reader-function type)))
437 (slot-value slotd 'getter)
439 (funcall reader (foreign-location object) offset)))))
441 (unless (slot-boundp slotd 'setter)
442 (let ((writer (writer-function type))
443 (destroy (destroy-function type)))
445 (slot-value slotd 'setter)
446 #'(lambda (value object)
447 (let ((location (foreign-location object)))
448 (funcall destroy location offset) ; destroy old value
449 (funcall writer value location offset))))))))
453 (defconstant +struct-alignmen+
454 #+sbcl (/ (sb-alien-internals:alien-type-alignment
455 (sb-alien-internals:parse-alien-type
456 'system-area-pointer nil))
460 (defun align-offset (size)
461 (if (zerop (mod size +struct-alignmen+))
463 (+ size (- +struct-alignmen+ (mod size +struct-alignmen+)))))
465 (defmethod compute-slots ((class proxy-class))
469 (eq (slot-definition-allocation slotd) :alien))
470 (class-direct-slots class))))
473 as offset = (align-offset (foreign-size
474 (most-specific-proxy-superclass class)))
477 (slot-definition-offset slotd)
478 (size-of (slot-definition-type slotd))))
479 for slotd in alien-slots
480 unless (slot-boundp slotd 'offset)
481 do (setf (slot-value slotd 'offset) offset))))
484 (defmethod validate-superclass ((class proxy-class) (super standard-class))
485 (subtypep (class-name super) 'proxy))
487 (defmethod foreign-size ((class-name symbol))
488 (foreign-size (find-class class-name))))
490 (defmethod foreign-size ((object proxy))
491 (foreign-size (class-of object)))
494 (define-type-method alien-type ((class proxy))
495 (declare (ignore class))
496 (alien-type 'pointer))
498 (define-type-method size-of ((class proxy))
499 (declare (ignore class))
502 (define-type-method from-alien-form ((type proxy) location)
503 (let ((class (type-expand type)))
504 `(ensure-proxy-instance ',class ,location)))
506 (define-type-method from-alien-function ((type proxy))
507 (let ((class (type-expand type)))
509 (ensure-proxy-instance class location))))
511 (define-type-method to-alien-form ((type proxy) instance)
512 (declare (ignore type))
513 `(foreign-location ,instance))
515 (define-type-method to-alien-function ((type proxy))
516 (declare (ignore type))
519 (define-type-method copy-from-alien-form ((type proxy) location)
520 (let ((class (type-expand type)))
521 `(ensure-proxy-instance ',class (reference-foreign ',class ,location))))
523 (define-type-method copy-from-alien-function ((type proxy))
524 (let ((class (type-expand type)))
526 (ensure-proxy-instance class (reference-foreign class location)))))
528 (define-type-method copy-to-alien-form ((type proxy) instance)
529 (let ((class (type-expand type)))
530 `(reference-foreign ',class (foreign-location ,instance))))
532 (define-type-method copy-to-alien-function ((type proxy))
533 (let ((class (type-expand type)))
535 (reference-foreign class (foreign-location instance)))))
537 (define-type-method writer-function ((type proxy))
538 (let ((class (type-expand type)))
539 #'(lambda (instance location &optional (offset 0))
540 (assert (null-pointer-p (sap-ref-sap location offset)))
542 (sap-ref-sap location offset)
543 (reference-foreign class (foreign-location instance))))))
545 (define-type-method reader-function ((type proxy))
546 (let ((class (type-expand type)))
547 #'(lambda (location &optional (offset 0) weak-p)
548 (declare (ignore weak-p))
549 (let ((instance (sap-ref-sap location offset)))
550 (unless (null-pointer-p instance)
551 (ensure-proxy-instance class (reference-foreign class instance)))))))
553 (define-type-method destroy-function ((type proxy))
554 (let ((class (type-expand type)))
555 #'(lambda (location &optional (offset 0))
556 (unreference-foreign class (sap-ref-sap location offset)))))
558 (define-type-method unbound-value ((type proxy))
559 (declare (ignore type))
562 (defun ensure-proxy-instance (class location &rest initargs)
563 "Returns a proxy object representing the foreign object at the give
564 location. If an existing object is not found in the cache
565 MAKE-PROXY-INSTANCE is called to create one."
566 (unless (null-pointer-p location)
568 #-debug-ref-counting(find-cached-instance location)
570 (let ((instance (find-cached-instance location)))
572 (format t "Object found in cache: ~A~%" instance)
574 (let ((instance (apply #'make-proxy-instance class location initargs)))
575 (cache-instance instance)
578 (defgeneric make-proxy-instance (class location &key weak)
579 (:documentation "Creates a new proxy object representing the foreign
580 object at the give location. If WEAK is non NIL the foreign memory
581 will not be released when the proxy is garbage collected."))
583 (defmethod make-proxy-instance ((class symbol) location &rest initargs)
584 (apply #'make-proxy-instance (find-class class) location initargs))
586 (defmethod make-proxy-instance ((class proxy-class) location &key weak)
589 (find-invalidated-instance class)
590 (allocate-instance class))))
591 (setf (foreign-location instance) location)
593 (finalize instance (instance-finalizer instance)))
597 ;;;; Superclasses for wrapping of C structures
599 (defclass struct (proxy)
601 (:metaclass proxy-class)
604 (defmethod allocate-foreign ((struct struct) &rest initargs)
605 (declare (ignore initargs))
606 (let ((size (foreign-size (class-of struct))))
608 (error "~A has zero size" (class-of struct))
609 (allocate-memory size))))
612 ;;;; Metaclasses used for subclasses of struct
614 (eval-when (:compile-toplevel :load-toplevel :execute)
615 (defclass struct-class (proxy-class)
618 (defmethod direct-slot-definition-class ((class struct-class) &rest initargs)
619 (if (not (getf initargs :allocation))
620 (find-class 'direct-alien-slot-definition)
623 (defmethod reference-foreign ((class struct-class) location)
624 (copy-memory location (foreign-size class)))
626 (defmethod unreference-foreign ((class struct-class) location)
627 (deallocate-memory location))
629 (defmethod compute-slots :around ((class struct-class))
630 (let ((slots (call-next-method)))
632 #-sbcl>=0.9.8(class-finalized-p class)
633 (not (slot-boundp class 'size)))
636 when (eq (slot-definition-allocation slotd) :alien)
638 (slot-definition-offset slotd)
639 (size-of (slot-definition-type slotd))))))
640 (setf (slot-value class 'size) (+ size (mod size +struct-alignmen+)))))
643 (define-type-method callback-from-alien-form ((type struct) form)
644 (let ((class (type-expand type)))
645 `(ensure-proxy-instance ',class ,form :weak t)))
647 (define-type-method callback-cleanup-form ((type struct) form)
648 (declare (ignore type))
649 `(invalidate-instance ,form))
651 (define-type-method reader-function ((type struct))
652 (let ((class (type-expand type)))
653 #'(lambda (location &optional (offset 0) weak-p)
654 (let ((instance (sap-ref-sap location offset)))
655 (unless (null-pointer-p instance)
657 (ensure-proxy-instance class instance :weak t)
658 (ensure-proxy-instance class (reference-foreign class instance))))))))
661 (defclass static-struct-class (struct-class)
664 (defmethod reference-foreign ((class static-struct-class) location)
665 (declare (ignore class))
668 (defmethod unreference-foreign ((class static-struct-class) location)
669 (declare (ignore class location))
672 ;;; Pseudo type for structs which are inlined in other objects
674 (deftype inlined (type) type)
676 (define-type-method size-of ((type inlined))
677 (let ((class (type-expand (second type))))
678 (foreign-size class)))
680 (define-type-method reader-function ((type inlined))
681 (let ((class (type-expand (second type))))
682 #'(lambda (location &optional (offset 0) weak-p)
683 (declare (ignore weak-p))
684 (ensure-proxy-instance class
685 (reference-foreign class (sap+ location offset))))))
687 (define-type-method writer-function ((type inlined))
688 (let ((class (type-expand (second type))))
689 #'(lambda (instance location &optional (offset 0))
690 (copy-memory (foreign-location instance) (foreign-size class) (sap+ location offset)))))