[gtk-cffi-cvs] CVS gtk-cffi/g-object

[CVS User rklochkov]

Update of /project/gtk-cffi/cvsroot/gtk-cffi/g-object
In directory tiger.common-lisp.net:/tmp/cvs-serv22276/g-object

Modified Files:
	defslots.lisp g-object-class.lisp g-object.lisp g-type.lisp 
	g-value.lisp pobject.lisp 
Log Message:
Added with-progress in extensions
Added GtkOrientable, GtkRange, GtkBuildable, & Cairo support in gdk (see examples/ex6)
Fixed all examples.



--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp	2012/03/06 01:25:26	1.11
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp	2012/05/07 09:02:04	1.12
@@ -148,7 +148,7 @@
         (cb-name (gensym)))
   `(progn
      (defcfun ,gtk-name :void
-       (,class pobject) (func pfunction) (data (pdata :free t)))
+       (,class pobject) (func pfunction) (data (pdata :free :all)))
      (defcallback ,cb-name :void ,params ;((tag pobject) (data pdata))
        (funcall *callback* ,@(mapcar #'car params)))
      (defmethod foreach ((,class ,class) func &optional data)
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object-class.lisp	2012/02/12 17:29:41	1.5
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object-class.lisp	2012/05/07 09:02:04	1.6
@@ -8,7 +8,7 @@
 (in-package #:g-object-cffi)
 
 (defclass g-object-class (object)
-  ())
+  ((free-after :initform nil)))
 
 (defcstruct g-object-class
   (type-class g-type-class)
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp	2012/02/20 16:51:37	1.9
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp	2012/05/07 09:02:04	1.10
@@ -168,8 +168,8 @@
 (defmethod connect ((g-object g-object) c-handler 
                     &key signal data after swapped)
   (let* ((str-signal (string-downcase signal))
-         (c-handler (if (and (symbolp c-handler) (fboundp c-handler)) 
-                        (symbol-function c-handler) c-handler)) 
+         (c-handler (if (and (symbolp c-handler) (fboundp c-handler))
+                        (symbol-function c-handler) c-handler))
          (handler-id
           (typecase c-handler
             (function (g-signal-connect-closure 
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-type.lisp	2012/03/06 01:25:26	1.6
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-type.lisp	2012/05/07 09:02:04	1.7
@@ -31,7 +31,7 @@
 
 (defcstruct g-type-instance
   "GTypeInstance"
-  (g-class g-type-class))
+  (g-class (:pointer g-type-class)))
 
 (defun g-type-from-instance (ptr)
   (foreign-slot-value 
@@ -95,22 +95,22 @@
                             (mapc #'princ (list "-" c))
                             (princ (char-upcase c))))))))
     (with-hash *types* g-type
-               (let ((typename (g-type-name g-type)))
-                 (when typename
-                   (or (cdr (assoc typename *typenames* :test 'string=))
-                       (let* ((pr-pos 
-                               (loop 
-                                  :for c :across (subseq typename 1)
-                                  :for i :from 1
-                                  :when (upper-case-p c) :return i))
-                              (prefix (subseq typename 0 pr-pos))
-                              (package
-                               (cdr (assoc prefix *gtk-packages*
-                                           :test 'string=))))
-                         (when package
-                           (intern (case-to-lisp
-                                    (subseq typename pr-pos))
-                                   package)))))))))
+      (let ((typename (g-type-name g-type)))
+        (when typename
+          (or (cdr (assoc typename *typenames* :test 'string=))
+              (let* ((pr-pos 
+                      (loop 
+                         :for c :across (subseq typename 1)
+                         :for i :from 1
+                         :when (upper-case-p c) :return i))
+                     (prefix (subseq typename 0 pr-pos))
+                     (package
+                      (cdr (assoc prefix *gtk-packages*
+                                  :test 'string=))))
+                (when package
+                    (intern (case-to-lisp
+                             (subseq typename pr-pos))
+                            package)))))))))
 
           
 (defcfun g-type-children (garray g-type) (type g-type) (n-children :pointer))
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-value.lisp	2012/02/20 16:51:37	1.4
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-value.lisp	2012/05/07 09:02:04	1.5
@@ -157,6 +157,8 @@
     (unless (null-pointer-p value)
       (let* ((g-type (type-g-value value))
              (fundamental-type (g-type-fundamental g-type)))
+        ;(format t "g-val:~a ~a ~a~%" g-type fundamental-type 
+        ;        (g-type->lisp g-type))
         (case fundamental-type
           (#.(keyword->g-type :boxed)
              (find-object (g-value-get-boxed value) 
@@ -174,7 +176,10 @@
                      fundamental-type :g-value-get-) value)))))))
 
 (defmethod value ((g-value g-value))
-  (g-value-get (pointer g-value)))
+  (let ((l
+         (g-value-get (pointer g-value))))
+    ;(format t "g-val2: ~a~%" l)
+    l))
 
 (defmethod free ((g-value g-value))
   (g-value-unset g-value)
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/pobject.lisp	2012/02/20 16:51:37	1.6
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/pobject.lisp	2012/05/07 09:02:04	1.7
@@ -19,8 +19,11 @@
 make up lisp object"
   (declare (type foreign-pointer ptr))
   (unless (null-pointer-p ptr)
+;    (format t "pobject: ~a~%" ptr)
     (let ((class (or (object-class cffi-pobject) 
                      (g-type->lisp (g-type-from-instance ptr)))))
+ ;     (format t "gtype: ~a :: ~a~%" (g-type-from-instance ptr) class)
+      
       (find-object ptr class))))
 
 ;; register as object type for g-list
@@ -50,7 +53,7 @@
 
 
 (define-foreign-type cffi-pdata (cffi-pobject freeable-base)
-  ()
+  ((free :initform :none))
   (:actual-type :pointer)
   (:simple-parser pdata)
   (:documentation "PDATA lets send any data via a c-pointer. C-pointer used as