From rklochkov at common-lisp.net Sun Oct 7 11:59:54 2012 From: rklochkov at common-lisp.net (rklochkov at common-lisp.net) Date: Sun, 07 Oct 2012 04:59:54 -0700 Subject: [cffi-objects-cvs] r12 - Message-ID: 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)