X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/80031aba3c00cfbf25e4a26d7b60522d759d8159..1d06a422f8e85b2e9c60a888399cd6a1662dfea1:/glib/gobject.lisp diff --git a/glib/gobject.lisp b/glib/gobject.lisp index 700d885..5b5087b 100644 --- a/glib/gobject.lisp +++ b/glib/gobject.lisp @@ -1,21 +1,26 @@ -;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 2000-2005 Espen S. Johnsen +;; Common Lisp bindings for GTK+ v2.x +;; Copyright 2000-2005 Espen S. Johnsen ;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2 of the License, or (at your option) any later version. +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation files (the +;; "Software"), to deal in the Software without restriction, including +;; without limitation the rights to use, copy, modify, merge, publish, +;; distribute, sublicense, and/or sell copies of the Software, and to +;; permit persons to whom the Software is furnished to do so, subject to +;; the following conditions: ;; -;; This library is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; Lesser General Public License for more details. +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. ;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE +;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. -;; $Id: gobject.lisp,v 1.35 2005/03/11 10:56:58 espen Exp $ +;; $Id: gobject.lisp,v 1.43 2006/02/05 15:38:57 espen Exp $ (in-package "GLIB") @@ -24,7 +29,8 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defclass gobject-class (ginstance-class) - ()) + ((instance-slots-p :initform nil + :documentation "Non NIL if the class has slots with instance allocation"))) (defmethod validate-superclass ((class gobject-class) (super standard-class)) ; (subtypep (class-name super) 'gobject) @@ -55,6 +61,27 @@ (defbinding %object-unref () nil (location pointer)) +#+glib2.8 +(progn + (defcallback toggle-ref-callback (nil (data pointer) (location pointer) (last-ref-p boolean)) + #+debug-ref-counting + (if last-ref-p + (format t "Object at 0x~8,'0X has no foreign references~%" (sap-int location)) + (format t "Foreign reference added to object at 0x~8,'0X~%" (sap-int location))) + (if last-ref-p + (cache-instance (find-cached-instance location) t) + (cache-instance (find-cached-instance location) nil))) + + (defbinding %object-add-toggle-ref () pointer + (location pointer) + ((callback toggle-ref-callback) pointer) + (nil null)) + + (defbinding %object-remove-toggle-ref () pointer + (location pointer) + ((callback toggle-ref-callback) pointer) + (nil null))) + (defmethod reference-foreign ((class gobject-class) location) (declare (ignore class)) (%object-ref location)) @@ -63,6 +90,16 @@ (declare (ignore class)) (%object-unref location)) +#+debug-ref-counting +(progn + (defcallback weak-ref-callback (nil (data pointer) (location pointer)) + (format t "Object at 0x~8,'0X being finalized~%" (sap-int location))) + + (defbinding %object-weak-ref () pointer + (location pointer) + ((callback weak-ref-callback) pointer) + (nil null))) + ; (defbinding object-class-install-param () nil ; (class pointer) @@ -151,6 +188,16 @@ (user-data-p object slot-name))))) (call-next-method)) +(defmethod shared-initialize :after ((class gobject-class) names &rest initargs) + (declare (ignore initargs)) + (when (some #'(lambda (slotd) + (and + (eq (slot-definition-allocation slotd) :instance) + (not (typep slotd 'effective-special-slot-definition)))) + (class-slots class)) + (setf (slot-value class 'instance-slots-p) t))) + + ;;;; Super class for all classes in the GObject type hierarchy @@ -177,9 +224,26 @@ initargs key pkey)) +(defmethod make-proxy-instance ((class gobject-class) location &rest initargs) + (declare (ignore location initargs)) + (if (slot-value class 'instance-slots-p) + (error "An object of class ~A has instance slots and should only be created with MAKE-INSTANCE" class) + (call-next-method))) + +(defmethod initialize-instance :around ((object gobject) &rest initargs) + (declare (ignore initargs)) + (call-next-method) + #+debug-ref-counting(%object-weak-ref (foreign-location object)) + #+glib2.8 + (when (slot-value (class-of object) 'instance-slots-p) + (with-slots (location) object + (%object-add-toggle-ref location) + (%object-unref location)))) + + (defmethod initialize-instance ((object gobject) &rest initargs) (unless (slot-boundp object 'location) - ;; Extract initargs which we should pass directly to the GObeject + ;; Extract initargs which we should pass directly to the GObject ;; constructor (let* ((slotds (class-slots (class-of object))) (args (when initargs @@ -227,10 +291,23 @@ (defmethod instance-finalizer ((instance gobject)) - (let ((location (proxy-location instance))) + (let ((location (foreign-location instance))) + #+glib2.8 + (if (slot-value (class-of instance) 'instance-slots-p) + #'(lambda () + #+debug-ref-counting + (format t "Finalizing proxy for 0x~8,'0X~%" (sap-int location)) + (remove-cached-instance location) + (%object-remove-toggle-ref location)) + #'(lambda () + #+debug-ref-counting + (format t "Finalizing proxy for 0x~8,'0X~%" (sap-int location)) + (remove-cached-instance location) + (%object-unref location))) + #-glib2.8 #'(lambda () (remove-cached-instance location) - (%object-unref location)))) + (%object-unref location)))) (defbinding (%gobject-new "g_object_new") () pointer @@ -459,7 +536,7 @@ (let ((instance (make-symbol "INSTANCE"))) `(let ((,instance ,(from-alien-form form type))) (when ,instance - (%object-unref (proxy-location ,instance))) + (%object-unref (foreign-location ,instance))) ,instance)) (error "~A is not a subclass of GOBJECT" type))))