Typo.

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

diff --git a/glib/gobject.object.high.lisp b/glib/gobject.object.high.lisp
index 2a3c751..f2b07b2 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)
@@ -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))
@@ -147,28 +160,32 @@
 (defun registered-object-type-by-name (name)
   (gethash name *registered-object-types*))
 (defun get-g-object-lisp-type (g-type)
-  (setf g-type (ensure-g-type g-type))
-  (loop
-     while (not (zerop g-type))
-     for lisp-type = (gethash (g-type-name g-type) *registered-object-types*)
-     when lisp-type do (return lisp-type)
-     do (setf g-type (ensure-g-type (g-type-parent g-type)))))
+  (setf g-type (gtype g-type))
+  (iter (while (not (null g-type)))
+        (for lisp-type = (gethash (gtype-name g-type) *registered-object-types*))
+        (when lisp-type
+          (return lisp-type))
+        (setf g-type (g-type-parent g-type))))
 
 (defun make-g-object-from-pointer (pointer)
   (let* ((g-type (g-type-from-instance pointer))
          (lisp-type (get-g-object-lisp-type g-type)))
     (unless lisp-type
       (error "Type ~A is not registered with REGISTER-OBJECT-TYPE"
-             (g-type-name g-type)))
+             (gtype-name g-type)))
     (let ((*current-object-from-pointer* pointer))
       (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,19 +210,13 @@
                (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)
 
-(defun ensure-g-type (type)
-  "Returns the GType value for a given type. If type is an integer, it is returned. If type is a string, GType corresponding to this type name is looked up and returned.
-@arg[type]{a string or and integer}
-@return{integer equal to GType of @code{type}}"
-  (etypecase type
-    (integer type)
-    (string (or (g-type-from-name type)
-                (error "Type ~A is invalid" type)))))
-
 (defun ensure-object-pointer (object)
   (if (pointerp object)
       object
@@ -217,16 +229,16 @@
 (defun set-gvalue-object (gvalue value)
   (g-value-set-object gvalue (if value (pointer value) (null-pointer))))
 
-(defmethod parse-g-value-for-type (gvalue-ptr (type-numeric (eql +g-type-object+)) parse-kind)
+(defmethod parse-g-value-for-type (gvalue-ptr (type (eql (gtype +g-type-object+))) parse-kind)
   (declare (ignore parse-kind))
   (parse-g-value-object gvalue-ptr))
 
-(defmethod parse-g-value-for-type (gvalue-ptr (type-numeric (eql +g-type-interface+)) parse-kind)
+(defmethod parse-g-value-for-type (gvalue-ptr (type (eql (gtype +g-type-interface+))) parse-kind)
   (declare (ignore parse-kind))
   (parse-g-value-object gvalue-ptr))
 
-(defmethod set-gvalue-for-type (gvalue-ptr (type-numeric (eql +g-type-object+)) value)
+(defmethod set-gvalue-for-type (gvalue-ptr (type (eql (gtype +g-type-object+))) value)
   (set-gvalue-object gvalue-ptr value))
 
-(defmethod set-gvalue-for-type (gvalue-ptr (type-numeric (eql +g-type-interface+)) value)
+(defmethod set-gvalue-for-type (gvalue-ptr (type (eql (gtype +g-type-interface+))) value)
   (set-gvalue-object gvalue-ptr value))