[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-serv6570/g-object

Modified Files:
	defslots.lisp g-object.lisp package.lisp pobject.lisp 
Log Message:
Several fixes for struct memory management.
Now we can use cffi-object:struct lisp values in place for cffi-object:pobject
when we don't rerturn value. When you need to fill pointer slot for struct,
just describe it as (object smth) in defcfun



--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp	2011/09/17 20:04:56	1.4
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/defslots.lisp	2011/09/21 12:03:47	1.5
@@ -126,5 +126,19 @@
            , at body)
        (free ,(or for-free name)))))
 
-
-
+(defvar *cb-foreach*)
+(defgeneric foreach (class func &optional data)
+  (:documentation "For each element in CLASS execute FUNC"))
+(defmacro make-foreach (class &rest params)
+  (let ((gtk-name (symbolicate 'gtk- class '-foreach))
+        (cb-name (gensym)))
+  `(progn
+     (defcfun ,gtk-name :void
+       (,class pobject) (func pfunction) (data (pdata :free t)))
+     (defcallback ,cb-name :void ,params ;((tag pobject) (data pdata))
+       (funcall *cb-foreach* ,@(mapcar #'car params)))
+     (defmethod foreach ((,class ,class) func &optional data)
+       (if (functionp func)
+           (let ((*cb-foreach* func))
+             (,gtk-name ,class (callback ,cb-name) data))
+           (,gtk-name ,class func data))))))
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp	2011/09/18 18:10:47	1.6
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp	2011/09/21 12:03:47	1.7
@@ -269,11 +269,11 @@
 
 (defgeneric ref (obj)
   (:method ((obj g-object))
-    (g-object-ref ref)))
+    (g-object-ref obj)))
 
 (defgeneric unref (obj)
   (:method ((obj g-object))
-    (g-object-unref ref)))
+    (g-object-unref obj)))
 
 (defcfun g-object-new :pointer (class-type g-type) (null :pointer))
 
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/package.lisp	2011/09/10 16:26:10	1.5
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/package.lisp	2011/09/21 12:03:47	1.6
@@ -85,4 +85,7 @@
    #:defgtkfun
    #:defgdkfun
    #:defgtkfuns
-   #:defgdkfuns))
+   #:defgdkfuns
+
+   #:foreach
+   #:make-foreach))
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/pobject.lisp	2011/08/26 17:16:13	1.3
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/pobject.lisp	2011/09/21 12:03:47	1.4
@@ -35,6 +35,9 @@
   On make-instance it allocates one byte on heap and associates itself
   with the address of that byte."))
 
+;; register as object type for g-list
+(defmethod g-lib-cffi::object-type ((type-name (eql 'pdata))) t)
+
 (defmethod gconstructor ((storage storage) &key &allow-other-keys)
   (foreign-alloc :char))
 
@@ -46,28 +49,47 @@
     (foreign-free data)))
 
 
-(define-foreign-type cffi-pdata (cffi-pobject)
+(define-foreign-type cffi-pdata (cffi-pobject freeable)
   ()
   (:actual-type :pointer)
-  (:simple-parser pdata)
   (:documentation "PDATA lets send any data via a c-pointer. C-pointer used as
 an id for the data. NB! Don't forget to free pointers after use."))
 
-(defmethod translate-from-foreign (ptr (name cffi-pdata))
-  "Returns saved data."
-  (let ((obj (object ptr :class 'storage)))
-    (when obj (data obj))))
+(define-parse-method pdata (&key free)
+  (make-instance 'cffi-pdata :free free))
 
-(defmethod translate-to-foreign (any-data (name cffi-pdata))
-  (if (or (null any-data) (pointerp any-data))
-      (call-next-method)
-      (translate-to-foreign (make-instance 'storage :data any-data) name)))
+(defmethod free-ptr ((type cffi-pdata) object) 
+                                        ; it's not typo: 
+                                        ;we free object, not pointer
+  (free object))
 
-(defmethod translate-to-foreign ((any-data storage) (name cffi-pdata))
-  (call-next-method))
+(defmethod translate-from-foreign (ptr (type cffi-pdata))
+  "Returns saved data."
+  (let ((obj (object ptr)))
+    (if obj 
+        (typecase obj
+          (storage (prog1 (data obj) (free-if-needed type obj)))
+          (t obj))
+        ptr)))
+
+(defmethod translate-to-foreign ((any-data object) (type cffi-pdata))
+  (pointer any-data))
+
+(defmethod translate-to-foreign ((any-data null) (type cffi-pdata))
+  (null-pointer))
+
+(defmethod translate-to-foreign (any-data (type cffi-pdata))
+  (if (pointerp any-data)
+      any-data
+      (let ((obj (make-instance 'storage :data any-data)))
+        (values (pointer obj) obj))))
+
+(defmethod free-translated-object (any-data (type cffi-pdata) param)
+  (when param
+    (free-if-needed type param)))
 
-(defmethod translate-to-foreign :around ((any-data storage) (name cffi-pdata))
-  (call-next-method any-data name))
+;; (defmethod translate-to-foreign :around ((any-data storage) (name cffi-pdata))
+;;   (call-next-method any-data name))
 
 ;; (define-foreign-type g-list-object (g-list)
 ;;   ()