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

Modified Files:
	g-object.lisp package.lisp pobject.lisp 
Log Message:
Fixed memory leaks



--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp	2012/05/07 09:02:04	1.10
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/g-object.lisp	2012/07/29 15:13:59	1.11
@@ -42,27 +42,34 @@
 ;;   (object pobject) (name :string) (value pobject))
 
 
+(define-foreign-type cffi-keyword ()
+  ()
+  (:simple-parser cffi-keyword)
+  (:actual-type :string))
+
+(defmethod translate-to-foreign (value (type cffi-keyword))
+  (convert-to-foreign (string-downcase value) :string))
+
 (defmacro generate-property-accessors (name object set get type
                                        class find prop-slot)
   `(progn
      (defgeneric ,type (,object key))
-     (defmethod ,type ((,object ,object) (key symbol))
-       (,type ,object (string-downcase key)))
-     (defmethod ,type ((,object ,object) (key string))
+     (defmethod ,type ((,object ,object) key)
        "Should return GType of property KEY."
-       (or (cdr (assoc key (,prop-slot ,object)))
-           (let* ((gclass (make-instance ',class :object ,object))
-                  (prop (,find gclass key)))
-             (when prop
-               (let ((g-type (g-type prop)))
-                 (setf (,prop-slot ,object)
-                       (acons key g-type (,prop-slot ,object)))
-                 g-type)))
-           (error "Incorrect property name ~a" key)))
+       (let ((skey (string-downcase key)))
+         (or (cdr (assoc skey (,prop-slot ,object) :test #'string=))
+             (let* ((gclass (make-instance ',class :object ,object))
+                    (prop (,find gclass skey)))
+               (when prop
+                 (let ((g-type (g-type prop)))
+                   (setf (,prop-slot ,object)
+                         (acons key g-type (,prop-slot ,object)))
+                   g-type)))
+             (error "Incorrect property name ~a" key))))
 
      ,@(when set
         `((defcfun ,set :void 
-            (object pobject) (name :string) (value pobject))
+            (object pobject) (name cffi-keyword) (value pobject))
           (defgeneric (setf ,name) (values ,object &rest keys))
           (defmethod (setf ,name) (values (,object ,object) &rest keys)
             "Usage: 
@@ -76,7 +83,7 @@
                   keys (if (listp values) values (list values))))))
 
      (defcfun ,get :void 
-       (object pobject) (name :string) (value pobject))     
+       (object pobject) (name cffi-keyword) (value pobject))
      (defgeneric ,name (,object &rest keys))
      (defmethod ,name ((,object ,object) &rest keys)
        "Usage 
@@ -84,11 +91,9 @@
          (property object :prop1 :prop2 ...) -> (value1 value2 ...)"
        (funcall (lambda (x) (if (cdr x) x (car x)))
                 (mapcar (lambda (key)
-                          (let* ((skey (string-downcase key))
-                                 (g-type (,type ,object skey)))
-                            (with-g-value
-                                (:g-type g-type)
-                              (,get ,object skey *g-value*))))
+                          (with-g-value
+                              (:g-type (,type ,object key))
+                            (,get ,object key *g-value*)))
                         keys)))))
 
 (generate-property-accessors property g-object 
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/package.lisp	2012/03/06 01:25:26	1.10
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/package.lisp	2012/07/29 15:13:59	1.11
@@ -11,6 +11,8 @@
         #:cffi-objects #:g-lib-cffi #:gtk-cffi-utils)
   (:export
 
+   #:cffi-keyword
+
    #:g-object
    ;; slots
    #:signals
--- /project/gtk-cffi/cvsroot/gtk-cffi/g-object/pobject.lisp	2012/05/07 09:02:04	1.7
+++ /project/gtk-cffi/cvsroot/gtk-cffi/g-object/pobject.lisp	2012/07/29 15:13:59	1.8
@@ -85,9 +85,9 @@
       (let ((obj (make-instance 'storage :data any-data)))
         (values (pointer obj) obj))))
 
-(defmethod free-translated-object (any-data (type cffi-pdata) param)
+(defmethod free-translated-object (ptr (type cffi-pdata) param)
   (when param
-    (free-sent-if-needed type param)))
+    (free-sent-if-needed type param param)))
 
 (defctype g-list-object (g-list :elt pobject))