From rklochkov at common-lisp.net Sun Jul 29 15:15:42 2012 From: rklochkov at common-lisp.net (rklochkov at common-lisp.net) Date: Sun, 29 Jul 2012 08:15:42 -0700 Subject: [cffi-objects-cvs] r5 - Message-ID: Author: rklochkov Date: Sun Jul 29 08:15:41 2012 New Revision: 5 Log: Fixed memory leaks Modified: freeable.lisp object.lisp redefines.lisp struct.lisp Modified: freeable.lisp ============================================================================== --- freeable.lisp Mon May 7 10:27:22 2012 (r4) +++ freeable.lisp Sun Jul 29 08:15:41 2012 (r5) @@ -21,25 +21,27 @@ appropriate places of your CFFI translators"))) (defgeneric free-ptr (type ptr) - (:documentation "Called to free ptr, unless overriden free-sent-ptr or free-returned-ptr.") + (:documentation "Called to free ptr, unless overriden free-sent-ptr +or free-returned-ptr.") (:method (type ptr) (foreign-free ptr))) -(defgeneric free-sent-ptr (type ptr) - (:method ((type freeable-base) ptr) - (format t "Free-sent-ptr: ~a ~a ~%" type ptr) +(defgeneric free-sent-ptr (type ptr param) + (:method ((type freeable-base) ptr param) + (declare (ignore param)) +; (format t "Free-sent-ptr: ~a ~a ~%" type ptr) (unless (null-pointer-p ptr) (free-ptr type ptr)))) (defgeneric free-returned-ptr (type ptr) (:method ((type freeable-base) ptr) - (format t "Free-returned-ptr: ~a ~a ~%" type ptr) +; (format t "Free-returned-ptr: ~a ~a ~%" type ptr) (unless (null-pointer-p ptr) (free-ptr type ptr)))) -(defun free-sent-if-needed (type ptr) +(defun free-sent-if-needed (type ptr param) (when (member (object-free type) '(t :all :container :no-transfer)) - (free-sent-ptr type ptr))) + (free-sent-ptr type ptr param))) (defun free-returned-if-needed (type ptr) (when (member (object-free type) '(t :all :container :transfer)) @@ -49,8 +51,7 @@ (:documentation "Mixing to auto-set translators")) (defmethod free-translated-object :after (ptr (type freeable) param) - (declare (ignore param)) - (free-sent-if-needed type ptr)) + (free-sent-if-needed type ptr param)) (defmethod translate-from-foreign :after (ptr (type freeable)) (free-returned-if-needed type ptr)) Modified: object.lisp ============================================================================== --- object.lisp Mon May 7 10:27:22 2012 (r4) +++ object.lisp Sun Jul 29 08:15:41 2012 (r5) @@ -132,7 +132,4 @@ value) (defmethod translate-from-foreign (ptr (cffi-object cffi-object)) - (find-object ptr (object-class cffi-object))) - - - + (find-object ptr (object-class cffi-object))) \ No newline at end of file Modified: redefines.lisp ============================================================================== --- redefines.lisp Mon May 7 10:27:22 2012 (r4) +++ redefines.lisp Sun Jul 29 08:15:41 2012 (r5) @@ -22,6 +22,9 @@ (defmethod translate-to-foreign ((value string) (type cffi-string)) (values (foreign-string-alloc value) value)) +(defmethod translate-to-foreign (value (type cffi-string)) + (values (foreign-string-alloc (string value)) value)) + (defmethod free-ptr ((type cffi-string) ptr) (foreign-string-free ptr)) Modified: struct.lisp ============================================================================== --- struct.lisp Mon May 7 10:27:22 2012 (r4) +++ struct.lisp Sun Jul 29 08:15:41 2012 (r5) @@ -21,6 +21,8 @@ (defgeneric free-struct (class value) (:method (class value) (declare (ignore class)) + ; (break) + (format t "Free ~a ~a~%" class value) (foreign-free value))) (defmethod gconstructor ((struct struct) &key new-struct &allow-other-keys) @@ -28,6 +30,7 @@ (new-struct (class-name (class-of struct))) (progn (setf (slot-value struct 'value) nil) + (setf (slot-value struct 'free-after) nil) (null-pointer)))) (defun pair (maybe-pair) @@ -102,23 +105,23 @@ (pointer object))) (defun struct->clos (class struct &optional object) - (unless object - (return-from struct->clos - (unless (null-pointer-p struct) - (make-instance class :pointer struct)))) - (if (slot-boundp object 'value) - (progn - (setf (slot-value object 'value) nil) - (mapc (lambda (slot) - (setf (getf (slot-value object 'value) slot) - (foreign-slot-value struct class slot))) - (foreign-slot-names class))) - (setf (pointer object) struct)) - ;(break) - object) - - - + "Translates pointer STRUCT to object OBJECT (if not supplied, then to new +object). + I suppose, that by default it should convert data from pointer to struct. +Only exception is the presence of OBJECT with not boundp value" + (let ((%object (or object + (unless (null-pointer-p struct) + (make-instance class :pointer struct))))) + (when %object + (if (slot-boundp %object 'value) + (progn + (setf (slot-value %object 'value) nil) + (unless (null-pointer-p struct) + (dolist (slot (foreign-slot-names class)) + (setf (getf (slot-value %object 'value) slot) + (foreign-slot-value struct class slot))))) + (setf (pointer %object) struct)) + %object))) (define-foreign-type cffi-struct (cffi-object freeable-out) () @@ -127,6 +130,11 @@ (defmethod free-ptr ((type cffi-struct) ptr) (free-struct (object-class type) ptr)) +(defmethod free-sent-ptr ((type cffi-struct) ptr place) + (when (and (slot-boundp place 'value) (not (null-pointer-p ptr))) + (free-struct (object-class type) ptr))) + + (defmethod foreign-type-size ((type cffi-struct)) "Return the size in bytes of a foreign typedef." (foreign-type-size (object-class type))) @@ -139,10 +147,10 @@ (or (object-class type) (class-name (class-of value)))) (defmethod copy-from-foreign ((type cffi-object) ptr place) - (when (or (slot-boundp place 'value) - (member (object-free type) '(:all :transfer))) + (when (slot-boundp place 'value) (struct->clos (%class type place) ptr place))) +;; cffi-object is not tyoo. It is for use struct with object designator (defmethod translate-to-foreign ((value struct) (type cffi-object)) (values (clos->new-struct (%class type value) value) value)) From rklochkov at common-lisp.net Sun Jul 29 16:11:18 2012 From: rklochkov at common-lisp.net (rklochkov at common-lisp.net) Date: Sun, 29 Jul 2012 09:11:18 -0700 Subject: [cffi-objects-cvs] r6 - Message-ID: Author: rklochkov Date: Sun Jul 29 09:11:18 2012 New Revision: 6 Log: Added cffi-keyword and cffi-pathname Modified: package.lisp redefines.lisp Modified: package.lisp ============================================================================== --- package.lisp Sun Jul 29 08:15:41 2012 (r5) +++ package.lisp Sun Jul 29 09:11:18 2012 (r6) @@ -45,6 +45,9 @@ #:null-array #:string-array + #:cffi-keyword + #:cffi-pathname + #:struct ; #:cffi-struct #:new-struct Modified: redefines.lisp ============================================================================== --- redefines.lisp Sun Jul 29 08:15:41 2012 (r5) +++ redefines.lisp Sun Jul 29 09:11:18 2012 (r6) @@ -31,3 +31,27 @@ (defmethod translate-from-foreign (ptr (type cffi-string)) (foreign-string-to-lisp ptr)) +(define-foreign-type cffi-keyword () + () + (:simple-parser cffi-keyword) + (:actual-type :string)) + +(defmethod translate-to-foreign ((value symbol) (type cffi-keyword)) + (convert-to-foreign (string-downcase value) :string)) + +(defmethod translate-to-foreign ((value string) (type cffi-keyword)) + (convert-to-foreign value :string)) + +(define-foreign-type cffi-pathname () + () + (:simple-parser cffi-pathname) + (:actual-type :string)) + +(defmethod translate-to-foreign ((value pathname) (type cffi-pathname)) + (convert-to-foreign (namestring value) :string)) + +(defmethod translate-to-foreign ((value string) (type cffi-pathname)) + (convert-to-foreign value :string)) + + +