Add compiler-macro that handles gtype calls with constant args

[cl-gtk2.git] / glib / gobject.object.high.lisp

diff --git a/glib/gobject.object.high.lisp b/glib/gobject.object.high.lisp
index 678fb2b..f1cca2e 100644 (file)
--- 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)
@@ -21,12 +21,29 @@
 (defvar *foreign-gobjects-strong* (make-hash-table :test 'equal))
 (defvar *current-creating-object* nil)
 (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))
   (let ((*current-creating-object* obj))
+    (log-for :subclass "initialize-instance :around; *current-creating-object* = ~A~%" obj)
     (call-next-method)))
 
 (defmethod initialize-instance :after ((obj g-object) &key &allow-other-keys)
@@ -160,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
@@ -174,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))))
 
@@ -188,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)