X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=inline;f=glib%2Fgobject.foreign-gobject.lisp;h=a4cad2bf40c063ccc8339b15d85db3e7c0bc7ab9;hb=9af0a44db2b9491749a7936c782c3d7ff1b804a3;hp=291ef952231a033606e36b27298da4be8a6c8b12;hpb=5e99c88b6f22ff0ecbc6d07f78cb6b1568307c75;p=cl-gtk2.git

diff --git a/glib/gobject.foreign-gobject.lisp b/glib/gobject.foreign-gobject.lisp
index 291ef95..a4cad2b 100644
--- a/glib/gobject.foreign-gobject.lisp
+++ b/glib/gobject.foreign-gobject.lisp
@@ -107,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
@@ -134,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))
@@ -193,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