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

[CVS User rklochkov]

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

Modified Files:
	package.lisp struct.lisp 
Log Message:
Fixed bug: now when one needs to free returned value after processing
(for example, color, font, structure), she or he may add " :free t" flag to
the foreign typename

Finished GtkTextView and GtkTextTag



--- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/package.lisp	2011/09/17 20:04:56	1.5
+++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/package.lisp	2011/09/18 18:10:47	1.6
@@ -33,6 +33,10 @@
    #:cffi-struct
    #:new-struct
    #:free-struct
+
+   #:freeable
+   #:free-if-needed
+   #:free-ptr
    
    #:defcstruct-accessors
    #:defcstruct*
--- /project/gtk-cffi/cvsroot/gtk-cffi/cffi/struct.lisp	2011/09/17 20:04:56	1.6
+++ /project/gtk-cffi/cvsroot/gtk-cffi/cffi/struct.lisp	2011/09/18 18:10:47	1.7
@@ -119,14 +119,17 @@
     (foreign-free value)))
 
 (defun clos->new-struct (class object)
-  (let ((res (new-struct class)))
-    (mapc (lambda (slot) (setf (foreign-slot-value res class slot)
-                               (cdr (assoc slot (slot-value object 'value)))))
-          (foreign-slot-names class))
-    res))
+  (if (slot-value object 'value)
+      (let ((res (new-struct class)))
+        (mapc (lambda (slot) (setf (foreign-slot-value res class slot)
+                                   (cdr (assoc slot 
+                                               (slot-value object 'value)))))
+              (foreign-slot-names class))
+        res)
+      (slot-value object 'pointer)))
 
 (defun struct->clos (class struct &optional object)
-  (let ((res (or object (make-instance class :pointer nil))))
+  (let ((res (or object (make-instance class))))
     (setf (slot-value res 'value) nil)
     (mapc (lambda (slot)
             (push (cons slot (foreign-slot-value struct class slot))
@@ -134,13 +137,32 @@
           (foreign-slot-names class))
     res))
 
-(define-foreign-type cffi-struct (cffi-object)
-  ((free :accessor obj-free :initarg :free 
-         :documentation "Free returned value")
-   (out :accessor obj-out :initarg :out
+(define-foreign-type freeable ()
+  ((free :accessor obj-free :initarg :free :initform nil
+         :documentation "Free returned value")))
+
+(defgeneric free-ptr (type ptr)
+  (:method ((type freeable) ptr)
+    (foreign-free ptr)))
+
+(defgeneric free-if-needed (type ptr)
+  (:method ((type freeable) ptr)
+    (when (obj-free type) (free-ptr type ptr))))
+
+(define-foreign-type cffi-struct (cffi-object freeable)
+  ((out :accessor obj-out :initarg :out
         :documentation "This is out param (for fill in gtk side)"))
   (:actual-type :pointer))
 
+(defmethod free-ptr ((type cffi-struct) ptr)
+  (free-struct (obj-class type) ptr))
+
+(defmethod foreign-type-size ((type cffi-struct))
+  "Return the size in bytes of a foreign typedef."
+  (foreign-type-size (obj-class type)))
+
+(defmethod cffi::aggregatep ((type cffi-struct)) t)
+
 (define-parse-method struct (class &key free out)
   (make-instance 'cffi-struct :class class :free free :out out))
 
@@ -157,7 +179,7 @@
   (let ((class (obj-class type)))
     (prog1 
         (struct->clos class value)
-      (when (obj-free type) (free-struct class value)))))
+      (free-if-needed type value))))
 
 ;; This is needed to get correct mem-aref, when used on array of structs
 (eval-when (:compile-toplevel :load-toplevel :execute)