[cffi-objects-cvs] r12 -

[rklochkov at common-lisp.net]

Author: rklochkov
Date: Sun Oct  7 04:59:54 2012
New Revision: 12

Log:
Fixed double free of object due to use of with-slots instead of setf (pointer object)

Modified:
   freeable.lisp
   object.lisp
   struct.lisp

Modified: freeable.lisp
==============================================================================
--- freeable.lisp	Fri Aug 24 13:47:10 2012	(r11)
+++ freeable.lisp	Sun Oct  7 04:59:54 2012	(r12)
@@ -54,10 +54,10 @@
   (free-returned-if-needed type ptr))
 
 (define-foreign-type freeable-out (freeable)
-  ((out :accessor object-out :initarg :out :initform t
+  ((out :accessor object-out :initarg :out :initform nil
         :documentation "This is out param (for fill in foreign side)"))
   (:documentation "For returning data in out params.
-To use translate-to-foreign MUST return (values ptr place)"))
+If OUT is t, then translate-to-foreign MUST return (values ptr place)"))
 
 (defgeneric copy-from-foreign (type ptr place)
   (:documentation "Transfers data from pointer PTR to PLACE"))

Modified: object.lisp
==============================================================================
--- object.lisp	Fri Aug 24 13:47:10 2012	(r11)
+++ object.lisp	Sun Oct  7 04:59:54 2012	(r12)
@@ -21,9 +21,9 @@
              :initarg :volatile :initform t
              :documentation "Will not be saved in hash")
    (free-after :type boolean :initarg :free-after :initform t
-               :documentation "Should be freed by finalizer")
+               :documentation "Should be freed by finalizer or FREE")
    (initialized :type list :initform nil 
-                :documentation "For SETF-INIT. To avoid double-init")
+                :documentation "For SETF-INIT. To avoid double init")
    (id :type symbol :accessor id :initarg :id :initform nil))
   (:documentation "Lisp wrapper for any object. VOLATILE slot set when object
 shouldn't be stored in *OBJECTS*. Stored pointer GC'ed, if VOLATILE."))
@@ -31,6 +31,7 @@
 (defmethod (setf pointer) :after (value (object object))
   (declare (type foreign-pointer value))
   (tg:cancel-finalization object)
+  ;(format t "Set pointer: ~a~%" object)
   (when (and (slot-value object 'free-after) (not (null-pointer-p value)))
     (let ((class (class-of object)))
       (format t "Set finalizer: ~a ~a ~a~%" object class value)
@@ -70,13 +71,16 @@
   (:documentation "Removes object pointer from lisp hashes."))
 
 (defmethod free ((object object))
+  ;(format t "Called free ~a~%" object)
   (with-slots (id pointer free-after) object
     (unless (null-pointer-p pointer)
       (remhash (pointer-address pointer) *objects*)
       (remhash id *objects-ids*)
       (when free-after
         (free-ptr (class-of object) pointer))
-      (setf pointer (null-pointer)
+      ;; if use (setf pointer (null-pointer)) then 
+      ;;   (setf pointer) method is not called
+      (setf (pointer object) (null-pointer) 
             id  nil))))
 
 (defun find-object (pointer &optional class)

Modified: struct.lisp
==============================================================================
--- struct.lisp	Fri Aug 24 13:47:10 2012	(r11)
+++ struct.lisp	Sun Oct  7 04:59:54 2012	(r12)
@@ -99,7 +99,8 @@
         (mapc (lambda (slot) 
                 (let ((val (getf (slot-value object 'value) slot default)))
                   (unless (eq val default)
-                    (setf (foreign-slot-value res class slot) val))))
+                    (setf (foreign-slot-value res (list :struct class) slot) 
+                          val))))
               (foreign-slot-names class))
         res)
       (pointer object)))
@@ -119,7 +120,7 @@
             (unless (null-pointer-p struct)
               (dolist (slot (foreign-slot-names class))
                 (setf (getf (slot-value %object 'value) slot) 
-                      (foreign-slot-value struct class slot)))))
+                      (foreign-slot-value struct (list :struct class) slot)))))
           (setf (pointer %object) struct))
       %object)))
 
@@ -128,7 +129,7 @@
   (:actual-type :pointer))
 
 (defmethod free-sent-ptr ((type cffi-struct) ptr place)
-  (when (and (slot-boundp place 'value) (not (null-pointer-p ptr)))
+  (when (and (not (null-pointer-p ptr)) (slot-boundp place 'value))
     (free-struct (object-class type) ptr)))
 
 (defmethod free-returned-ptr ((type cffi-struct) ptr)