[cffi-objects-cvs] r5 -
rklochkov at common-lisp.net
rklochkov at common-lisp.net
Sun Jul 29 15:15:42 UTC 2012
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))
More information about the cffi-objects-cvs
mailing list