From rklochkov at common-lisp.net Thu Aug 9 16:55:24 2012 From: rklochkov at common-lisp.net (rklochkov at common-lisp.net) Date: Thu, 09 Aug 2012 09:55:24 -0700 Subject: [cffi-objects-cvs] r7 - Message-ID: Author: rklochkov Date: Thu Aug 9 09:55:23 2012 New Revision: 7 Log: Added function INITIALIZE Modified: object.lisp package.lisp redefines.lisp setters.lisp struct.lisp Modified: object.lisp ============================================================================== --- object.lisp Sun Jul 29 09:11:18 2012 (r6) +++ object.lisp Thu Aug 9 09:55:23 2012 (r7) @@ -22,6 +22,8 @@ :documentation "Will not be saved in hash") (free-after :type boolean :initarg :free-after :initform t :documentation "Should be freed by finalizer") + (initialized :type list :initform nil + :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.")) Modified: package.lisp ============================================================================== --- package.lisp Sun Jul 29 09:11:18 2012 (r6) +++ package.lisp Thu Aug 9 09:55:23 2012 (r7) @@ -24,6 +24,7 @@ #:free-after #:find-object #:object-by-id + #:initialize #:*objects* #:*objects-ids* #:object-class @@ -47,6 +48,7 @@ #:cffi-keyword #:cffi-pathname + #:cffi-string #:struct ; #:cffi-struct Modified: redefines.lisp ============================================================================== --- redefines.lisp Sun Jul 29 09:11:18 2012 (r6) +++ redefines.lisp Thu Aug 9 09:55:23 2012 (r7) @@ -31,7 +31,7 @@ (defmethod translate-from-foreign (ptr (type cffi-string)) (foreign-string-to-lisp ptr)) -(define-foreign-type cffi-keyword () +(define-foreign-type cffi-keyword (freeable) () (:simple-parser cffi-keyword) (:actual-type :string)) @@ -42,7 +42,7 @@ (defmethod translate-to-foreign ((value string) (type cffi-keyword)) (convert-to-foreign value :string)) -(define-foreign-type cffi-pathname () +(define-foreign-type cffi-pathname (freeable) () (:simple-parser cffi-pathname) (:actual-type :string)) Modified: setters.lisp ============================================================================== --- setters.lisp Sun Jul 29 09:11:18 2012 (r6) +++ setters.lisp Thu Aug 9 09:55:23 2012 (r7) @@ -31,9 +31,21 @@ (field-p (if (consp field-all) (third field-all) field-all))) `(when ,field-p - (setf (,field ,object) ,field)))) + (unless (initialized ,object ,field) + (setf (,field ,object) ,field) + (initialize ,object ,field))))) fields))) +(defun initialized (obj field) + (find field (slot-value obj 'initialized))) + +(defun initialize (obj fields) + "Used when you need to mark, that FIELDS already initialized" + (etypecase fields + (list (dolist (field fields) + (initialize obj field))) + (symbol (push fields (slot-value obj 'initialized))))) + (defun name-p (name) (intern (format nil "~a-P" name) (symbol-package name))) Modified: struct.lisp ============================================================================== --- struct.lisp Sun Jul 29 09:11:18 2012 (r6) +++ struct.lisp Thu Aug 9 09:55:23 2012 (r7) @@ -22,7 +22,7 @@ (:method (class value) (declare (ignore class)) ; (break) - (format t "Free ~a ~a~%" class value) + ;(format t "Free ~a ~a~%" class value) (foreign-free value))) (defmethod gconstructor ((struct struct) &key new-struct &allow-other-keys) From rklochkov at common-lisp.net Sun Aug 12 17:36:30 2012 From: rklochkov at common-lisp.net (rklochkov at common-lisp.net) Date: Sun, 12 Aug 2012 10:36:30 -0700 Subject: [cffi-objects-cvs] r8 - Message-ID: Author: rklochkov Date: Sun Aug 12 10:36:30 2012 New Revision: 8 Log: Changed API for freeable to be consistent with CFFI: changed :FREE to :FREE-FROM-FOREIGN and :FREE-TO-FOREIGN as in :STRING Synced with last version of CFFI Modified: array.lisp freeable.lisp package.lisp redefines.lisp setters.lisp struct.lisp Modified: array.lisp ============================================================================== --- array.lisp Thu Aug 9 09:55:23 2012 (r7) +++ array.lisp Sun Aug 12 10:36:30 2012 (r8) @@ -13,8 +13,8 @@ ((element-type :initarg :type :accessor element-type)) (:actual-type :pointer)) -(define-parse-method carray (type &key free) - (make-instance 'cffi-array :type type :free free)) +(define-parse-method carray (type &rest rest) + (apply #'make-instance 'cffi-array :type type rest)) (defmethod translate-to-foreign (value (cffi-array cffi-array)) (if (pointerp value) @@ -38,8 +38,8 @@ ((element-type :initarg :type :accessor element-type)) (:actual-type :pointer)) -(define-parse-method null-array (type &key free) - (make-instance 'cffi-null-array :type type :free free)) +(define-parse-method null-array (type &rest rest) + (apply #'make-instance 'cffi-null-array :type type rest)) (defmethod translate-to-foreign (value (cffi-null-array cffi-null-array)) (if (pointerp value) Modified: freeable.lisp ============================================================================== --- freeable.lisp Thu Aug 9 09:55:23 2012 (r7) +++ freeable.lisp Sun Aug 12 10:36:30 2012 (r8) @@ -8,17 +8,17 @@ (in-package #:cffi-objects) (define-foreign-type freeable-base () - ((free :accessor object-free :initarg :free :initform :no-transfer - :type (member nil :none t :all :no-transfer :transfer :container) - :documentation "Free returned or sent value. -: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 -contained items -You should call FREE-RETURNED-IF-NEEDED and FREE-SENT-IF-NEEDED in -appropriate places of your CFFI translators"))) + ;; Should we free after translating from foreign? + ((free-from-foreign :initarg :free-from-foreign + :reader fst-free-from-foreign-p + :initform nil :type boolean) + ;; Should we free after translating to foreign? + (free-to-foreign :initarg :free-to-foreign + :reader fst-free-to-foreign-p + :initform t :type boolean))) + +;; You should call FREE-RETURNED-IF-NEEDED and FREE-SENT-IF-NEEDED in +;; appropriate places of your CFFI translators"))) (defgeneric free-ptr (type ptr) (:documentation "Called to free ptr, unless overriden free-sent-ptr @@ -29,22 +29,20 @@ (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) (unless (null-pointer-p ptr) (free-ptr type ptr)))) (defun free-sent-if-needed (type ptr param) - (when (member (object-free type) '(t :all :container :no-transfer)) + (when (fst-free-to-foreign-p type) (free-sent-ptr type ptr param))) (defun free-returned-if-needed (type ptr) - (when (member (object-free type) '(t :all :container :transfer)) + (when (fst-free-from-foreign-p type) (free-returned-ptr type ptr))) (defclass freeable (freeable-base) () Modified: package.lisp ============================================================================== --- package.lisp Thu Aug 9 09:55:23 2012 (r7) +++ package.lisp Sun Aug 12 10:36:30 2012 (r8) @@ -62,6 +62,8 @@ #:free-ptr #:freeable-out #:copy-from-foreign + #:free-from-foreign + #:free-to-foreign #:defcstruct-accessors #:defcstruct* Modified: redefines.lisp ============================================================================== --- redefines.lisp Thu Aug 9 09:55:23 2012 (r7) +++ redefines.lisp Sun Aug 12 10:36:30 2012 (r8) @@ -13,34 +13,19 @@ `(let ((,var (coerce ,value 'double-float))) , at body) `(let ((,var ,value)) , at body))) -;; make type string with :free for uniformity -(define-foreign-type cffi-string (freeable) - () - (:actual-type :pointer) - (:simple-parser pstring)) - -(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)) - -(defmethod translate-from-foreign (ptr (type cffi-string)) - (foreign-string-to-lisp ptr)) - (define-foreign-type cffi-keyword (freeable) () (:simple-parser cffi-keyword) - (:actual-type :string)) + (:actual-type :pointer)) (defmethod translate-to-foreign ((value symbol) (type cffi-keyword)) - (convert-to-foreign (string-downcase value) :string)) + (foreign-string-alloc (string-downcase value))) (defmethod translate-to-foreign ((value string) (type cffi-keyword)) - (convert-to-foreign value :string)) + (foreign-string-alloc value)) + +(defmethod free-ptr ((type cffi-keyword) ptr) + (foreign-string-free ptr)) (define-foreign-type cffi-pathname (freeable) () Modified: setters.lisp ============================================================================== --- setters.lisp Thu Aug 9 09:55:23 2012 (r7) +++ setters.lisp Sun Aug 12 10:36:30 2012 (r8) @@ -33,7 +33,7 @@ `(when ,field-p (unless (initialized ,object ,field) (setf (,field ,object) ,field) - (initialize ,object ,field))))) + (initialize ,object ',field))))) fields))) (defun initialized (obj field) Modified: struct.lisp ============================================================================== --- struct.lisp Thu Aug 9 09:55:23 2012 (r7) +++ struct.lisp Sun Aug 12 10:36:30 2012 (r8) @@ -51,17 +51,17 @@ (if (slot-boundp ,class-name 'value) (getf (slot-value ,class-name 'value) ',x) (foreign-slot-value (pointer ,class-name) - ',struct-name ',x))) + '(:struct ,struct-name) ',x))) (unless (fboundp '(setf ,x)) (defgeneric (setf ,x) (val ,class-name))) (defmethod (setf ,x) (val (,class-name ,class-name)) (if (slot-boundp ,class-name 'value) (setf (getf (slot-value ,class-name 'value) ',x) val) (setf (foreign-slot-value (pointer ,class-name) - ',struct-name ',x) + '(:struct ,struct-name) ',x) val))) (save-setter ,class-name ,x))) - (foreign-slot-names struct-name))))) + (foreign-slot-names `(:struct ,struct-name)))))) (defmacro defbitaccessors (class slot &rest fields) (let ((pos 0)) @@ -139,9 +139,8 @@ "Return the size in bytes of a foreign typedef." (foreign-type-size (object-class type))) -(define-parse-method struct (class &key (free :no-transfer) out) - (make-instance 'cffi-struct - :class class :free free :out out)) +(define-parse-method struct (class &rest rest) + (apply #'make-instance 'cffi-struct :class class rest)) (defun %class (type value) (or (object-class type) (class-name (class-of value)))) From rklochkov at common-lisp.net Fri Aug 24 19:26:54 2012 From: rklochkov at common-lisp.net (rklochkov at common-lisp.net) Date: Fri, 24 Aug 2012 12:26:54 -0700 Subject: [cffi-objects-cvs] r9 - Message-ID: Author: rklochkov Date: Fri Aug 24 12:26:53 2012 New Revision: 9 Log: Fixed FREE-PTR generic. First param is a symbol Modified: freeable.lisp redefines.lisp struct.lisp Modified: freeable.lisp ============================================================================== --- freeable.lisp Sun Aug 12 10:36:30 2012 (r8) +++ freeable.lisp Fri Aug 24 12:26:53 2012 (r9) @@ -22,28 +22,27 @@ (defgeneric free-ptr (type ptr) (:documentation "Called to free ptr, unless overriden free-sent-ptr -or free-returned-ptr.") +or free-returned-ptr. TYPE should be specialized with EQL") (:method (type ptr) (foreign-free ptr))) -(defgeneric free-sent-ptr (type ptr param) - (:method ((type freeable-base) ptr param) - (declare (ignore param)) +(defgeneric free-sent-ptr (cffi-type ptr param) + (:method ((cffi-type freeable-base) ptr param) (unless (null-pointer-p ptr) - (free-ptr type ptr)))) + (free-ptr (type-of cffi-type) ptr)))) -(defgeneric free-returned-ptr (type ptr) - (:method ((type freeable-base) ptr) +(defgeneric free-returned-ptr (cffi-type ptr) + (:method ((cffi-type freeable-base) ptr) (unless (null-pointer-p ptr) - (free-ptr type ptr)))) + (free-ptr (type-of cffi-type) ptr)))) -(defun free-sent-if-needed (type ptr param) - (when (fst-free-to-foreign-p type) - (free-sent-ptr type ptr param))) - -(defun free-returned-if-needed (type ptr) - (when (fst-free-from-foreign-p type) - (free-returned-ptr type ptr))) +(defun free-sent-if-needed (cffi-type ptr param) + (when (fst-free-to-foreign-p cffi-type) + (free-sent-ptr cffi-type ptr param))) + +(defun free-returned-if-needed (cffi-type ptr) + (when (fst-free-from-foreign-p cffi-type) + (free-returned-ptr cffi-type ptr))) (defclass freeable (freeable-base) () (:documentation "Mixing to auto-set translators")) Modified: redefines.lisp ============================================================================== --- redefines.lisp Sun Aug 12 10:36:30 2012 (r8) +++ redefines.lisp Fri Aug 24 12:26:53 2012 (r9) @@ -24,7 +24,7 @@ (defmethod translate-to-foreign ((value string) (type cffi-keyword)) (foreign-string-alloc value)) -(defmethod free-ptr ((type cffi-keyword) ptr) +(defmethod free-ptr ((type (eql 'cffi-keyword)) ptr) (foreign-string-free ptr)) (define-foreign-type cffi-pathname (freeable) Modified: struct.lisp ============================================================================== --- struct.lisp Sun Aug 12 10:36:30 2012 (r8) +++ struct.lisp Fri Aug 24 12:26:53 2012 (r9) @@ -127,13 +127,14 @@ () (:actual-type :pointer)) -(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 free-returned-ptr ((type cffi-struct) ptr) + (unless (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." From rklochkov at common-lisp.net Fri Aug 24 20:44:53 2012 From: rklochkov at common-lisp.net (rklochkov at common-lisp.net) Date: Fri, 24 Aug 2012 13:44:53 -0700 Subject: [cffi-objects-cvs] r10 - Message-ID: Author: rklochkov Date: Fri Aug 24 13:44:53 2012 New Revision: 10 Log: Free pointed object on FREE method Modified: object.lisp Modified: object.lisp ============================================================================== --- object.lisp Fri Aug 24 12:26:53 2012 (r9) +++ object.lisp Fri Aug 24 13:44:53 2012 (r10) @@ -73,6 +73,8 @@ (unless (null-pointer-p (pointer object)) (remhash (pointer-address (pointer object)) *objects*) (remhash (id object) *objects-ids*) + (when (and (slot-value object 'free-after) (not (null-pointer-p value))) + (free-ptr (class-of object) value)) (setf (pointer object) (null-pointer) (id object) nil))) From rklochkov at common-lisp.net Fri Aug 24 20:47:10 2012 From: rklochkov at common-lisp.net (rklochkov at common-lisp.net) Date: Fri, 24 Aug 2012 13:47:10 -0700 Subject: [cffi-objects-cvs] r11 - Message-ID: Author: rklochkov Date: Fri Aug 24 13:47:10 2012 New Revision: 11 Log: Bugfix Modified: object.lisp Modified: object.lisp ============================================================================== --- object.lisp Fri Aug 24 13:44:53 2012 (r10) +++ object.lisp Fri Aug 24 13:47:10 2012 (r11) @@ -70,13 +70,14 @@ (:documentation "Removes object pointer from lisp hashes.")) (defmethod free ((object object)) - (unless (null-pointer-p (pointer object)) - (remhash (pointer-address (pointer object)) *objects*) - (remhash (id object) *objects-ids*) - (when (and (slot-value object 'free-after) (not (null-pointer-p value))) - (free-ptr (class-of object) value)) - (setf (pointer object) (null-pointer) - (id object) nil))) + (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) + id nil)))) (defun find-object (pointer &optional class) "Returns lisp object for an Object pointer.