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

[CVS User rklochkov]

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

Modified Files:
	list.lisp package.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-lib/list.lisp	2011/08/28 10:31:30	1.4
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/list.lisp	2011/09/21 12:03:47	1.5
@@ -11,14 +11,11 @@
 ;; I don't see where one can use GList as is. So there is no such class.
 ;; Only convertors to and from lisp lists
 
-(defcfun "g_list_free" :void (g-list :pointer))
-
-(defcfun "g_list_foreach" :void 
+(defcfun g-list-free :void (g-list :pointer))
+(defcfun g-list-foreach :void 
   (g-list :pointer) (func :pointer) (data :pointer))
-
-(defcfun "g_list_prepend" :pointer (g-list :pointer) (data object))
-
-(defcfun "g_list_reverse" :pointer (glist :pointer))
+(defcfun g-list-prepend :pointer (g-list :pointer) (data object))
+(defcfun g-list-reverse :pointer (g-list :pointer))
 
 (defvar *list*)
 (defvar *list-type*)
@@ -33,32 +30,34 @@
   (declare (ignore user-data))
   (push (cond
           ((null *list-type*) data)
-          ((or (object-type *list-type*)
-               (and (consp *list-type*) (object-type (car *list-type*))))
+          ((object-type (ensure-car *list-type*))
            (convert-from-foreign data *list-type*))
           (t (mem-ref data *list-type*))) *list*))
 
-(define-foreign-type g-list ()
+(define-foreign-type g-list (freeable)
   ((list-type :initarg :type :accessor list-type 
               :documentation "If null, then list is of pointers or GObjects"))
   (:actual-type :pointer))
 
-(define-parse-method g-list (&optional type)
-  (make-instance 'g-list :type type))
+(define-parse-method g-list (&optional type &key free)
+  (make-instance 'g-list :type type :free free))
+
+(defmethod free-ptr ((type g-list) ptr)
+  (g-list-free ptr))
 
 (defmethod translate-from-foreign (ptr (g-list g-list))
   (declare (type foreign-pointer ptr))
   (let ((*list* nil)
         (*list-type* (list-type g-list)))
     (g-list-foreach ptr (callback list-collect) (null-pointer))
-    (g-list-free ptr)
+    (g-list-free ptr)  ;; FIXME: if exists GLists, that shouldn't be freed 
     (nreverse *list*)))
 
 (defmethod translate-to-foreign (lisp-list (g-list g-list))
   (declare (type list lisp-list))
   (let ((converter
          (let ((list-type (list-type g-list)))
-           (if list-type
+           (if (and list-type (not (object-type (ensure-car list-type))))
              (lambda (x) (foreign-alloc list-type :initial-element x))
              #'identity))))
     (let ((p (null-pointer)))
@@ -66,3 +65,50 @@
               (setf p (g-list-prepend p (apply converter x))))
             lisp-list)
       (g-list-reverse p))))
+
+(defmethod free-translated-object (ptr (type g-list) param)
+  (free-if-needed type ptr))
+
+;; Copy-paste fom g-list. Bad, but what to do?
+(define-foreign-type g-slist (freeable)
+  ((list-type :initarg :type :accessor list-type 
+              :documentation "If null, then list is of pointers or GObjects"))
+  (:actual-type :pointer))
+
+(define-parse-method g-slist (&optional type &key free)
+  (make-instance 'g-slist :type type :free free))
+
+(defcfun g-slist-free :void (g-slist :pointer))
+(defcfun g-slist-foreach :void 
+  (g-list :pointer) (func :pointer) (data :pointer))
+(defcfun g-slist-prepend :pointer (g-slist :pointer) (data object))
+(defcfun g-slist-reverse :pointer (g-slist :pointer))
+
+
+(defmethod free-ptr ((type g-slist) ptr)
+  (g-slist-free ptr))
+
+(defmethod translate-from-foreign (ptr (g-slist g-slist))
+  (declare (type foreign-pointer ptr))
+  (let ((*list* nil)
+        (*list-type* (list-type g-slist)))
+    (g-slist-foreach ptr (callback list-collect) (null-pointer))
+    (g-slist-free ptr)
+    (nreverse *list*)))
+
+(defmethod translate-to-foreign (lisp-list (g-slist g-slist))
+  (declare (type list lisp-list))
+  (let ((converter
+         (let ((list-type (list-type g-slist)))
+           (if (and list-type (not (object-type (ensure-car list-type))))
+             (lambda (x) (foreign-alloc list-type :initial-element x))
+             #'identity))))
+    (let ((p (null-pointer)))
+      (mapc (lambda (x)
+              (setf p (g-slist-prepend p (apply converter x))))
+            lisp-list)
+      (g-slist-reverse p))))
+
+(defmethod free-translated-object (ptr (type g-slist) param)
+  (free-if-needed type ptr))
+
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/package.lisp	2011/09/10 16:26:10	1.3
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-lib/package.lisp	2011/09/21 12:03:47	1.4
@@ -9,13 +9,14 @@
 
 (defpackage #:g-lib-cffi
   (:nicknames #:g-lib #:glib)
-  (:use #:common-lisp #:cffi #:cffi-object #:iterate)
+  (:use #:common-lisp #:cffi #:cffi-object #:iterate #:alexandria)
   (:export
    ;; gerror macro
    #:with-g-error
    
    ;; types
    #:g-list
+   #:g-slist
    #:g-quark
    #:g-error
    #:garray