From rklochkov at common-lisp.net Fri May 4 11:25:20 2012 From: rklochkov at common-lisp.net (rklochkov at common-lisp.net) Date: Fri, 04 May 2012 04:25:20 -0700 Subject: [cffi-objects-cvs] r3 - Message-ID: Author: rklochkov Date: Fri May 4 04:25:20 2012 New Revision: 3 Log: Fixes with GC Modified: cffi-objects.asd freeable.lisp object.lisp package.lisp struct.lisp Modified: cffi-objects.asd ============================================================================== --- cffi-objects.asd Mon Feb 20 10:55:20 2012 (r2) +++ cffi-objects.asd Fri May 4 04:25:20 2012 (r3) @@ -17,7 +17,7 @@ :depends-on (cffi trivial-garbage) :components ((:file package) - (:file redefines :depends-on (package)) + (:file redefines :depends-on (package freeable)) (:file freeable :depends-on (package)) (:file object :depends-on (freeable)) (:file pfunction :depends-on (package)) Modified: freeable.lisp ============================================================================== --- freeable.lisp Mon Feb 20 10:55:20 2012 (r2) +++ freeable.lisp Fri May 4 04:25:20 2012 (r3) @@ -27,10 +27,12 @@ (defgeneric free-sent-ptr (type ptr) (:method ((type freeable-base) ptr) + (format t "Free-sent-ptr: ~a ~a ~%" type 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) (free-ptr type ptr))) (defun free-sent-if-needed (type ptr) Modified: object.lisp ============================================================================== --- object.lisp Mon Feb 20 10:55:20 2012 (r2) +++ object.lisp Fri May 4 04:25:20 2012 (r3) @@ -31,7 +31,9 @@ (tg:cancel-finalization object) (when (and (slot-value object 'free-after) (not (null-pointer-p value))) (let ((class (class-of object))) - (tg:finalize object (lambda () + (format t "Set finalizer: ~a ~a ~a~%" object class value) + (tg:finalize object (lambda () + (format t "Finalize: ~a ~a~%" class value) (free-ptr class value))))) ; specialize EQL CLASS to override (unless (or (volatile object) (null-pointer-p value)) @@ -77,7 +79,7 @@ If not found or found with wrong class, create new one with given CLASS" (declare (type symbol class) (type foreign-pointer pointer)) (unless (null-pointer-p pointer) - (let ((try-find (gethash (pointer-address pointer) *objects*))) + (let ((try-find (gethash (pointer-address pointer) *objects*))) (if class (progn (unless (or (null try-find) @@ -85,7 +87,9 @@ (progn (free try-find) (setf try-find nil))) - (or try-find (make-instance class :pointer pointer))) + (or try-find (make-instance class + :pointer pointer + :free-after nil))) try-find)))) (defun object-by-id (id-key) @@ -117,6 +121,12 @@ (type cffi::foreign-pointer-type)) (null-pointer)) +;; nil = null string +(defmethod translate-to-foreign ((value null) + (type cffi::foreign-string-type)) + (null-pointer)) + + (defmethod translate-to-foreign (value (type cffi-object)) (check-type value foreign-pointer) value) Modified: package.lisp ============================================================================== --- package.lisp Mon Feb 20 10:55:20 2012 (r2) +++ package.lisp Fri May 4 04:25:20 2012 (r3) @@ -21,6 +21,7 @@ #:gconstructor #:object + #:free-after #:find-object #:object-by-id #:*objects* Modified: struct.lisp ============================================================================== --- struct.lisp Mon Feb 20 10:55:20 2012 (r2) +++ struct.lisp Fri May 4 04:25:20 2012 (r3) @@ -142,7 +142,7 @@ (struct->clos (object-class type) value)) ;;; Allowed use with object designator -;; object == (struct nil :out t :free t) +;; object == (struct nil) ;; to allow using array of structs From rklochkov at common-lisp.net Mon May 7 17:27:22 2012 From: rklochkov at common-lisp.net (rklochkov at common-lisp.net) Date: Mon, 07 May 2012 10:27:22 -0700 Subject: [cffi-objects-cvs] r4 - Message-ID: Author: rklochkov Date: Mon May 7 10:27:22 2012 New Revision: 4 Log: Minor fixes Modified: freeable.lisp object.lisp struct.lisp Modified: freeable.lisp ============================================================================== --- freeable.lisp Fri May 4 04:25:20 2012 (r3) +++ freeable.lisp Mon May 7 10:27:22 2012 (r4) @@ -9,10 +9,10 @@ (define-foreign-type freeable-base () ((free :accessor object-free :initarg :free :initform :no-transfer - :type (member :none :all :no-transfer :transfer :container) + :type (member nil :none t :all :no-transfer :transfer :container) :documentation "Free returned or sent value. -:NONE -- no free at all -:ALL -- free always (after sending to FFI, or after recieved translation) +:NONE, nil -- no free at all +:ALL, t -- free always (after sending to FFI, or after recieved translation) :TRANSFER -- client frees, so free after recieve :NO-TRANSFER -- host frees, so free after sending to FFI. :CONTAINER -- the object is a container, ALL for container and NO-TRANSFER for @@ -28,19 +28,21 @@ (defgeneric free-sent-ptr (type ptr) (:method ((type freeable-base) ptr) (format t "Free-sent-ptr: ~a ~a ~%" type ptr) - (free-ptr 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) - (free-ptr type ptr))) + (unless (null-pointer-p ptr) + (free-ptr type ptr)))) (defun free-sent-if-needed (type ptr) - (when (member (object-free type) '(:all :container :no-transfer)) + (when (member (object-free type) '(t :all :container :no-transfer)) (free-sent-ptr type ptr))) (defun free-returned-if-needed (type ptr) - (when (member (object-free type) '(:all :container :transfer)) + (when (member (object-free type) '(t :all :container :transfer)) (free-returned-ptr type ptr))) (defclass freeable (freeable-base) () Modified: object.lisp ============================================================================== --- object.lisp Fri May 4 04:25:20 2012 (r3) +++ object.lisp Mon May 7 10:27:22 2012 (r4) @@ -90,7 +90,7 @@ (or try-find (make-instance class :pointer pointer :free-after nil))) - try-find)))) + (or try-find pointer))))) (defun object-by-id (id-key) (gethash id-key *objects-ids*)) Modified: struct.lisp ============================================================================== --- struct.lisp Fri May 4 04:25:20 2012 (r3) +++ struct.lisp Mon May 7 10:27:22 2012 (r4) @@ -99,16 +99,24 @@ (setf (foreign-slot-value res class slot) val)))) (foreign-slot-names class)) res) - (slot-value object 'pointer))) + (pointer object))) (defun struct->clos (class struct &optional object) - (let ((res (or object (make-instance class)))) - (setf (slot-value res 'value) nil) - (mapc (lambda (slot) - (setf (getf (slot-value res 'value) slot) - (foreign-slot-value struct class slot))) - (foreign-slot-names class)) - res)) + (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) +