X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=glib%2Fgobject.object.high.lisp;h=f1cca2ed331c5814fc35ce2db7625ea1823d7cf7;hb=bcc0750a3031ca5bfb5d1084f56e60e1ab991973;hp=2a3c7516ba8b6f2bf7804e856a4c1b10a538a2db;hpb=4779b2e12b19f4d3ea431b3784bbe0b8a463962d;p=cl-gtk2.git

diff --git a/glib/gobject.object.high.lisp b/glib/gobject.object.high.lisp
index 2a3c751..f1cca2e 100644
--- a/glib/gobject.object.high.lisp
+++ b/glib/gobject.object.high.lisp
@@ -2,7 +2,7 @@
 
 (defclass g-object ()
   ((pointer
-    :type cffi:foreign-pointer
+    :type (or null cffi:foreign-pointer)
     :initarg :pointer
     :accessor pointer
     :initform nil)
@@ -23,9 +23,22 @@
 (defvar *current-object-from-pointer* nil)
 (defvar *currently-making-object-p* nil)
 
+(at-finalize ()
+  (clrhash *foreign-gobjects-weak*)
+  (clrhash *foreign-gobjects-strong*)
+  (setf *current-creating-object* nil
+        *current-object-from-pointer* nil
+        *currently-making-object-p* nil))
+
 (defun ref-count (pointer)
   (foreign-slot-value (if (pointerp pointer) pointer (pointer pointer)) 'g-object-struct :ref-count))
 
+(defmethod release ((obj g-object))
+  (cancel-finalization obj)
+  (let ((p (pointer obj)))
+    (setf (pointer obj) nil)
+    (g-object-dispose-carefully p)))
+
 (defmethod initialize-instance :around ((obj g-object) &key)
   (when *currently-making-object-p*
     (setf *currently-making-object-p* t))
@@ -164,11 +177,15 @@
       (make-instance lisp-type :pointer pointer))))
 
 (define-foreign-type foreign-g-object-type ()
-  ((sub-type :reader sub-type :initarg :sub-type :initform 'g-object))
+  ((sub-type :reader sub-type :initarg :sub-type :initform 'g-object)
+   (already-referenced :reader foreign-g-object-type-already-referenced :initarg :already-referenced :initform nil))
   (:actual-type :pointer))
 
-(define-parse-method g-object (&optional (sub-type 'g-object))
-  (make-instance 'foreign-g-object-type :sub-type sub-type))
+(define-parse-method g-object (&rest args)
+  (let* ((sub-type (first (remove-if #'keywordp args)))
+         (flags (remove-if-not #'keywordp args))
+         (already-referenced (not (null (find :already-referenced flags)))))
+    (make-instance 'foreign-g-object-type :sub-type sub-type :already-referenced already-referenced)))
 
 (defmethod translate-to-foreign (object (type foreign-g-object-type))
   (cond
@@ -178,9 +195,10 @@
     ((null (pointer object))
      (error "Object ~A has been disposed" object))
     ((typep object 'g-object)
-     (assert (typep object (sub-type type))
-             nil
-             "Object ~A is not a subtype of ~A" object (sub-type type))
+     (when (sub-type type)
+       (assert (typep object (sub-type type))
+               nil
+               "Object ~A is not a subtype of ~A" object (sub-type type)))
      (pointer object))
     (t (error "Object ~A is not translatable as GObject*" object))))
 
@@ -192,7 +210,10 @@
                (make-g-object-from-pointer pointer)))))
 
 (defmethod translate-from-foreign (pointer (type foreign-g-object-type))
-  (get-g-object-for-pointer pointer))
+  (let ((object (get-g-object-for-pointer pointer)))
+    (when (and object (foreign-g-object-type-already-referenced type))
+      (g-object-unref (pointer object)))
+    object))
 
 (register-object-type "GObject" 'g-object)