X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=glib%2Fgobject.foreign-gobject.lisp;h=a4cad2bf40c063ccc8339b15d85db3e7c0bc7ab9;hb=14e2e5e92540c66b674aaeb0062e9b872e993c73;hp=a84c6b376eecc4bbb91d2b439f357527556b50a3;hpb=ba11f152e513f7e2b2b422518cc261669f55ed5e;p=cl-gtk2.git

diff --git a/glib/gobject.foreign-gobject.lisp b/glib/gobject.foreign-gobject.lisp
index a84c6b3..a4cad2b 100644
--- a/glib/gobject.foreign-gobject.lisp
+++ b/glib/gobject.foreign-gobject.lisp
@@ -13,6 +13,8 @@
 
 (defvar *foreign-gobjects* (make-weak-hash-table :test 'equal :weakness :value))
 (defvar *foreign-gobjects-ref-count* (make-hash-table :test 'equal))
+(defvar *lisp-objects-pointers* (make-hash-table :test 'equal))
+(defvar *current-creating-object* nil)
 
 (defcstruct g-object-struct
   (type-instance g-type-instance)
@@ -22,11 +24,15 @@
 (defun ref-count (pointer)
   (foreign-slot-value (if (pointerp pointer) pointer (pointer pointer)) 'g-object-struct 'ref-count))
 
+(defmethod initialize-instance :around ((obj g-object) &key)
+  (let ((*current-creating-object* obj))
+    (call-next-method)))
+
 (defmethod initialize-instance :after ((obj g-object) &key &allow-other-keys)
   (unless (slot-boundp obj 'pointer)
     (error "Pointer slot is not initialized for ~A" obj))
   (let* ((pointer (pointer obj))
-         (s (format nil obj)))
+         (s (format nil "~A" obj)))
     (finalize obj
               (lambda ()
                 (handler-case
@@ -69,6 +75,13 @@
   (declare (ignore data))
   (debugf "g-object has finalized ~A ~A~%" (g-type-name (g-type-from-object object-pointer)) object-pointer))
 
+(defun erase-pointer (data object-pointer)
+  (declare (ignore data))
+  (remhash (pointer-address object-pointer) *lisp-objects-pointers*))
+
+(defcallback weak-notify-erase-pointer :void ((data :pointer) (object-pointer :pointer))
+  (erase-pointer data object-pointer))
+
 (defun should-ref-sink-at-creation (object)
 ;;If object was not created from lisp-side, we should ref it
 ;;If an object is regular g-object, we should not ref-sink it
@@ -81,11 +94,12 @@
       t))
 
 (defun register-g-object (obj)
-  (debugf "registered GObject ~A with ref-count ~A ~A~%" (pointer obj) (ref-count obj) (if (g-object-is-floating (pointer obj)) "(floating)" ""))
+  (debugf "registered GObject ~A with gobject ref-count ~A ~A~%" (pointer obj) (ref-count obj) (if (g-object-is-floating (pointer obj)) "(floating)" ""))
   (when (should-ref-sink-at-creation obj)
     (debugf "g_object_ref_sink(~A)~%" (pointer obj))
     (g-object-ref-sink (pointer obj)))
   (g-object-weak-ref (pointer obj) (callback weak-notify-print) (null-pointer))
+  (g-object-weak-ref (pointer obj) (callback weak-notify-erase-pointer) (null-pointer))
   (setf (g-object-has-reference obj) t)
   (setf (gethash (pointer-address (pointer obj)) *foreign-gobjects*)
         obj)
@@ -93,7 +107,7 @@
 
 (defun g-object-dispose (pointer)
   (unless (gethash (pointer-address pointer) *foreign-gobjects-ref-count*)
-    (format t "GObject ~A is already disposed, signalling error~%" pointer)
+    (debugf "GObject ~A is already disposed, signalling error~%" pointer)
     (error "GObject ~A is already disposed" pointer))
   (debugf "g_object_unref(~A) (of type ~A, lisp-value ~A) (lisp ref-count ~A, gobject ref-count ~A)~%"
           pointer
@@ -120,6 +134,8 @@
 (defvar *registered-object-types* (make-hash-table :test 'equal))
 (defun register-object-type (name type)
   (setf (gethash name *registered-object-types*) type))
+(defun registered-object-type-by-name (name)
+  (gethash name *registered-object-types*))
 (defun get-g-object-lisp-type (g-type)
   (loop
      while (not (zerop g-type))
@@ -179,33 +195,35 @@
       (etypecase object
         (g-object (pointer object)))))
 
+(defun g-param-spec-property-type (param-spec property-name object-type assert-readable assert-writable)
+  (when (null-pointer-p param-spec)
+           (error "Property ~A on type ~A is not found"
+                  property-name
+                  (g-type-name object-type)))
+  (when (and assert-readable
+             (not (member :readable
+                          (foreign-slot-value param-spec
+                                              'g-param-spec
+                                              'flags))))
+    (error "Property ~A on type ~A is not readable"
+           property-name
+           (g-type-name object-type)))
+  (when (and assert-writable
+             (not (member :writable
+                          (foreign-slot-value param-spec
+                                              'g-param-spec
+                                              'flags))))
+    (error "Property ~A on type ~A is not writable"
+           property-name
+           (g-type-name object-type)))
+  (foreign-slot-value param-spec 'g-param-spec 'value-type))
+
 (defun g-object-type-property-type (object-type property-name
                                     &key assert-readable assert-writable)
   (let* ((object-class (g-type-class-ref object-type))
          (param-spec (g-object-class-find-property object-class property-name)))
     (unwind-protect
-         (progn
-           (when (null-pointer-p param-spec)
-             (error "Property ~A on type ~A is not found"
-                    property-name
-                    (g-type-name object-type)))
-           (when (and assert-readable
-                      (not (member :readable
-                                   (foreign-slot-value param-spec
-                                                       'g-param-spec
-                                                       'flags))))
-             (error "Property ~A on type ~A is not readable"
-                    property-name
-                    (g-type-name object-type)))
-           (when (and assert-writable
-                      (not (member :writable
-                                   (foreign-slot-value param-spec
-                                                       'g-param-spec
-                                                       'flags))))
-             (error "Property ~A on type ~A is not writable"
-                    property-name
-                    (g-type-name object-type)))
-           (foreign-slot-value param-spec 'g-param-spec 'value-type))
+         (g-param-spec-property-type param-spec property-name object-type assert-readable assert-writable)
       (g-type-class-unref object-class))))
 
 (defun g-object-property-type (object property-name