Fixes for memory management of g-boxed-refs

diff --git a/glib/gobject.foreign-gboxed.lisp b/glib/gobject.foreign-gboxed.lisp
index 1cd1ffc..b218397 100644 (file)
--- a/glib/gobject.foreign-gboxed.lisp
+++ b/glib/gobject.foreign-gboxed.lisp
@@ -200,6 +200,7 @@
 
 (defvar *known-boxed-refs* (tg:make-weak-hash-table :test 'equal :weakness :value))
 (defvar *boxed-ref-count* (make-hash-table :test 'equal))
+(defvar *boxed-ref-owner* (make-hash-table :test 'equal))
 
 (defun boxed-ref-free-function (name)
   (or (get name 'free-function)
@@ -217,13 +218,17 @@
            (gethash (pointer-address pointer) *boxed-ref-count*)))
   (aif (gethash (pointer-address pointer) *known-boxed-refs*)
        (tg:cancel-finalization it))
-  (funcall (boxed-ref-free-function type) pointer)
+  (when (eq :lisp (gethash (pointer-address pointer) *boxed-ref-owner*))
+    (funcall (boxed-ref-free-function type) pointer))
   (remhash (pointer-address pointer) *known-boxed-refs*)
-  (remhash (pointer-address pointer) *boxed-ref-count*))
+  (remhash (pointer-address pointer) *boxed-ref-count*)
+  (remhash (pointer-address pointer) *boxed-ref-owner*))
 
 (defmethod initialize-instance :after ((object g-boxed-ref) &key)
-  (setf (gethash (pointer-address (pointer object)) *known-boxed-refs*) object)
-  (setf (gethash (pointer-address (pointer object)) *boxed-ref-count*) 1)
+  (let ((address (pointer-address (pointer object))))
+    (setf (gethash address *known-boxed-refs*) object)
+    (setf (gethash address *boxed-ref-count*) 1)
+    (setf (gethash address *boxed-ref-owner*) :foreign))
   (debugf "setting g-boxed-ref-count of ~A to 1~%" (pointer object))
   (let ((p (pointer object))
         (type (type-of object))
@@ -242,26 +247,28 @@
     (dispose-boxed-ref (type-of object) (pointer object))))
 
 (define-foreign-type g-boxed-ref-type ()
-  ((class-name :reader g-boxed-ref-class-name :initarg :class-name))
+  ((class-name :reader g-boxed-ref-class-name :initarg :class-name)
+   (owner :reader g-boxed-ref-owner :initarg :owner :initform nil))
   (:actual-type :pointer))
 
-(define-parse-method g-boxed-ref (class-name)
+(define-parse-method g-boxed-ref (class-name &key (owner :lisp))
   (unless (get class-name 'is-g-boxed-ref)
     (error "~A is not a subtype of G-BOXED-REF (~A: ~S)" class-name class-name (symbol-plist class-name)))
-  (make-instance 'g-boxed-ref-type :class-name class-name))
+  (make-instance 'g-boxed-ref-type :class-name class-name :owner owner))
 
 (defmethod translate-to-foreign (value (type g-boxed-ref-type))
   (if value
       (pointer value)
       (null-pointer)))
 
-(defun convert-g-boxed-ref-from-pointer (pointer name)
+(defun convert-g-boxed-ref-from-pointer (pointer name type)
   (unless (null-pointer-p pointer)
     (or (gethash (pointer-address pointer) *known-boxed-refs*)
-        (make-instance name :pointer pointer))))
+        (prog1 (make-instance name :pointer pointer)
+          (setf (gethash (pointer-address pointer) *boxed-ref-owner*) (g-boxed-ref-owner type))))))
 
 (defmethod translate-from-foreign (value (type g-boxed-ref-type))
-  (convert-g-boxed-ref-from-pointer value (g-boxed-ref-class-name type)))
+  (convert-g-boxed-ref-from-pointer value (g-boxed-ref-class-name type) type))
 
 (defun g-boxed-ref-slot->methods (class slot)
   (bind (((slot-name &key reader writer type) slot))
@@ -282,9 +289,10 @@
         (slots (rest (find :slots properties :key 'first))))
     (unless (and free-fn alloc-fn) (error "All of :free-function, :alloc-function must be specified"))
     `(progn (defclass ,name (g-boxed-ref) ())
-            (defmethod initialize-instance ((object ,name) &key)
-              (unless (slot-boundp object 'pointer)
-                (setf (pointer object) (,alloc-fn))))
+            (defmethod initialize-instance :before ((object ,name) &key pointer)
+              (unless (or pointer (slot-boundp object 'pointer))
+                (setf (pointer object) (,alloc-fn)
+                      (gethash (pointer-address pointer) *boxed-ref-owner*) :lisp)))
             (setf (get ',name 'free-function) ',free-fn)
             (eval-when (:compile-toplevel :load-toplevel :execute)
               (setf (get ',name 'is-g-boxed-ref) t))
@@ -329,5 +337,5 @@
       (return-from parse-gvalue-boxed nil))
     (unless (null-pointer-p (g-value-get-boxed gvalue))
       (cond
-        ((subtypep boxed-type 'g-boxed-ref) (convert-g-boxed-ref-from-pointer (g-value-get-boxed gvalue) boxed-type))
+        ((subtypep boxed-type 'g-boxed-ref) (convert-g-boxed-ref-from-pointer (g-value-get-boxed gvalue) boxed-type (make-instance 'g-boxed-ref-type :class-name boxed-type)))
         (t (parse-g-boxed (g-value-get-boxed gvalue) boxed-type))))))
\ No newline at end of file