X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/e2ebafb115b201d38b16f2ee7064b8514ea6b2e3..c0e198829957eb9122532707013fb324f4ef1d14:/glib/gobject.lisp diff --git a/glib/gobject.lisp b/glib/gobject.lisp index 43a8da7..bd0151f 100644 --- a/glib/gobject.lisp +++ b/glib/gobject.lisp @@ -20,7 +20,7 @@ ;; 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.38 2006-02-02 22:35:12 espen Exp $ +;; $Id: gobject.lisp,v 1.45 2006-02-08 22:10:47 espen Exp $ (in-package "GLIB") @@ -28,6 +28,7 @@ (in-package "GLIB") ;;;; Metaclass used for subclasses of gobject (eval-when (:compile-toplevel :load-toplevel :execute) +;; (push :debug-ref-counting *features*) (defclass gobject-class (ginstance-class) ((instance-slots-p :initform nil :documentation "Non NIL if the class has slots with instance allocation"))) @@ -61,33 +62,44 @@ (defbinding %object-ref () pointer (defbinding %object-unref () nil (location pointer)) -(defcallback toggle-ref-callback (nil (data pointer) (location pointer) (last-ref-p boolean)) - (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)) +#+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)) - (if (slot-value class 'instance-slots-p) - (%object-add-toggle-ref location) - (%object-ref location))) + (%object-ref location)) (defmethod unreference-foreign ((class gobject-class) location) (declare (ignore class)) - (error "Should never be called on a GOBJECT-CLASS (if this is ever needed some redesigning would have to be done)") -; (%object-unref location) -) + (%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 @@ -192,10 +204,18 @@ (defmethod shared-initialize :after ((class gobject-class) names &rest initargs) (eval-when (:compile-toplevel :load-toplevel :execute) (defclass gobject (ginstance) - () + (#+debug-ref-counting + (ref-count :allocation :alien :type int :reader ref-count)) (:metaclass gobject-class) (:gtype "GObject"))) +#+debug-ref-counting +(defmethod print-object ((instance gobject) stream) + (print-unreadable-object (instance stream :type t :identity nil) + (if (proxy-valid-p instance) + (format stream "at 0x~X (~D)" (sap-int (foreign-location instance)) (ref-count instance)) + (write-string "at \"unbound\"" stream)))) + (defun initial-add (object function initargs key pkey) (loop @@ -213,8 +233,25 @@ (defun initial-apply-add (object function initargs key pkey) 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) + (unless (proxy-valid-p object) ;; Extract initargs which we should pass directly to the GObject ;; constructor (let* ((slotds (class-slots (class-of object))) @@ -247,7 +284,7 @@ (defmethod initialize-instance ((object gobject) &rest initargs) (gvalue-init (sap+ tmp string-size) type value)) (unwind-protect (setf - (slot-value object 'location) + (foreign-location object) (%gobject-newv (type-number-of object) (length args) params)) (loop repeat (length args) @@ -256,21 +293,30 @@ (defmethod initialize-instance ((object gobject) &rest initargs) (gvalue-unset (sap+ tmp string-size))) (deallocate-memory params))) (setf - (slot-value object 'location) + (foreign-location object) (%gobject-new (type-number-of object)))))) (apply #'call-next-method object initargs)) (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))))) + (%object-unref location))) + #-glib2.8 + #'(lambda () + (remove-cached-instance location) + (%object-unref location)))) (defbinding (%gobject-new "g_object_new") () pointer @@ -499,7 +545,7 @@ (defmethod from-alien-form (form (type (eql 'referenced)) &rest args) (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))))