From 44ad7044e286d3219ec4bba45b4aae575dffcd66 Mon Sep 17 00:00:00 2001 Message-Id: <44ad7044e286d3219ec4bba45b4aae575dffcd66.1713537759.git.mdw@distorted.org.uk> From: Mark Wooding Date: Thu, 9 Oct 2008 18:20:52 +0000 Subject: [PATCH] Moved handling of floating references from gtk to glib Organization: Straylight/Edgeware From: espen --- glib/defpackage.lisp | 4 +-- glib/gobject.lisp | 62 +++++++++++++++++++++++++++++++++----------- gtk/gtkobject.lisp | 34 ++++++++++++------------ 3 files changed, 67 insertions(+), 33 deletions(-) diff --git a/glib/defpackage.lisp b/glib/defpackage.lisp index ae0eae1..33ef768 100644 --- a/glib/defpackage.lisp +++ b/glib/defpackage.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: defpackage.lisp,v 1.26 2007-10-17 14:30:00 espen Exp $ +;; $Id: defpackage.lisp,v 1.27 2008-10-09 18:20:52 espen Exp $ (defpackage "GLIB" @@ -89,7 +89,7 @@ (defpackage "GLIB" "USER-DATA-DESTROY-CALLBACK" "USER-DATA-P" "UNSET-USER-DATA" "QUERY-OBJECT-CLASS-PROPERTIES" "SLOT-DEFINITIONS" "EXPAND-GOBJECT-TYPE" "GOBJECT-DEPENDENCIES" "SIGNAL-NAME-TO-STRING" - "REFERENCED") + "REFERENCED" "INITIALLY-UNOWNED") ;; Symbols from ginterface.lisp (:export "INTERFACE" "INTERFACE-CLASS" "QUERY-OBJECT-INTERFACE-PROPERTIES") ;; Symbols from gerror.lisp diff --git a/glib/gobject.lisp b/glib/gobject.lisp index e9cbffd..a9d4735 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.57 2007-06-01 10:46:15 espen Exp $ +;; $Id: gobject.lisp,v 1.58 2008-10-09 18:20:52 espen Exp $ (in-package "GLIB") @@ -32,18 +32,26 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (defclass gobject-class (ginstance-class) ((instance-slots-p :initform nil :reader instance-slots-p :documentation "Non NIL if the class has slots with instance allocation"))) - (defmethod shared-initialize ((class gobject-class) names &rest initargs) - (declare (ignore names initargs)) - (call-next-method) - (unless (slot-boundp class 'ref) - (setf (slot-value class 'ref) '%object-ref)) - (unless (slot-boundp class 'unref) - (setf (slot-value class 'unref) '%object-unref))) (defmethod validate-superclass ((class gobject-class) (super standard-class)) ; (subtypep (class-name super) 'gobject) t)) +(defmethod slot-unbound (metaclass (class gobject-class) (slot (eql 'ref))) + (assert (class-direct-superclasses class)) + (setf (slot-value class 'ref) + #?-(pkg-exists-p "glib-2.0" :atleast-version "2.10.0") '%object-ref + #?(pkg-exists-p "glib-2.0" :atleast-version "2.10.0") + ;; We do this hack instead of creating a new metaclass to avoid + ;; breaking backward compatibility + (if (subtypep (class-name class) 'initially-unowned) + '%object-ref-sink + '%object-ref))) + +(defmethod slot-unbound (metaclass (class gobject-class) (slot (eql 'unref))) + (setf (slot-value class 'unref) '%object-unref)) + + (defclass direct-property-slot-definition (direct-virtual-slot-definition) ((pname :reader slot-definition-pname :initarg :pname) (readable :reader slot-readable-p :initarg :readable) @@ -334,11 +342,12 @@ (defmethod initialize-instance :around ((object gobject) &rest initargs) (declare (ignore initargs)) (prog1 (call-next-method) - #+debug-ref-counting(%object-weak-ref (foreign-location object)) - #?(pkg-exists-p "glib-2.0" :atleast-version "2.8.0") - (when (slot-value (class-of object) 'instance-slots-p) - (%object-add-toggle-ref (foreign-location object)) - (%object-unref (foreign-location object))))) + (let ((location (foreign-location object))) + #+debug-ref-counting(%object-weak-ref location) + #?(pkg-exists-p "glib-2.0" :atleast-version "2.8.0") + (when (slot-value (class-of object) 'instance-slots-p) + (%object-add-toggle-ref location) + (%object-unref location))))) (defmethod instance-finalizer ((instance gobject)) @@ -347,11 +356,15 @@ (defmethod instance-finalizer ((instance gobject)) (if (slot-value (class-of instance) 'instance-slots-p) #'(lambda () #+debug-ref-counting - (format t "Finalizing proxy for 0x~8,'0X~%" (pointer-address location)) + (format t "Finalizing proxy for 0x~8,'0X (~A)~%" + (pointer-address location) + (find-foreign-type-name (%type-number-of-ginstance location))) (%object-remove-toggle-ref location)) #'(lambda () #+debug-ref-counting - (format t "Finalizing proxy for 0x~8,'0X~%" (pointer-address location)) + (format t "Finalizing proxy for 0x~8,'0X (~A)~%" + (pointer-address location) + (find-foreign-type-name (%type-number-of-ginstance location))) (%object-unref location))) #?-(pkg-exists-p "glib-2.0" :atleast-version "2.8.0") #'(lambda () @@ -368,6 +381,25 @@ (defbinding (%gobject-newv "g_object_newv") () pointer (params pointer)) +;;;; Floating references + +#?(pkg-exists-p "glib-2.0" :atleast-version "2.10.0") +(progn + (defclass initially-unowned (gobject) + () + (:metaclass gobject-class) + (:gtype "GInitiallyUnowned")) + + (defbinding %object-ref-sink () pointer + (location pointer)) + + (defbinding %object-is-floating () boolean + (location pointer)) + + (defmethod initialize-instance :before ((object initially-unowned) &rest initargs) + (declare (ignore initargs)) + (%object-ref-sink (foreign-location object)))) + ;;;; Property stuff diff --git a/gtk/gtkobject.lisp b/gtk/gtkobject.lisp index c098921..2a49629 100644 --- a/gtk/gtkobject.lisp +++ b/gtk/gtkobject.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: gtkobject.lisp,v 1.47 2008-03-06 22:02:08 espen Exp $ +;; $Id: gtkobject.lisp,v 1.48 2008-10-09 18:20:52 espen Exp $ (in-package "GTK") @@ -29,12 +29,12 @@ (in-package "GTK") ;;;; Superclass for the gtk class hierarchy (eval-when (:compile-toplevel :load-toplevel :execute) - (init-types-in-library gtk "libgtk-2.0") + (init-types-in-library gtk "libgtk-2.0")) - (defclass %object (gobject) - () - (:metaclass gobject-class) - (:gtype |gtk_object_get_type|))) +(defclass %object (initially-unowned) + () + (:metaclass gobject-class) + (:gtype |gtk_object_get_type|)) (defmethod initialize-instance ((object %object) &rest initargs &key signal) @@ -43,16 +43,18 @@ (defmethod initialize-instance ((object %object) &rest initargs &key signal) (dolist (signal-definition (get-all initargs :signal)) (apply #'signal-connect object signal-definition))) -(defmethod initialize-instance :around ((object %object) &rest initargs) - (declare (ignore initargs)) - (call-next-method) - ;; Add a temorary reference which will be removed when the object is - ;; sinked - (funcall (reference-function '%object) (foreign-location object)) - (%object-sink object)) - -(defbinding %object-sink () nil - (object %object)) +#?-(pkg-exists-p "glib-2.0" :atleast-version "2.10.0") +(progn + (defmethod initialize-instance :around ((object %object) &rest initargs) + (declare (ignore initargs)) + (call-next-method) + ;; Add a temorary reference which will be removed when the object is + ;; sinked + (funcall (reference-function '%object) (foreign-location object)) + (%object-sink object)) + + (defbinding %object-sink () nil + (object %object))) ;;;; Main loop and event handling -- [mdw]