[cffi-objects-cvs] r8 -
rklochkov at common-lisp.net
rklochkov at common-lisp.net
Sun Aug 12 17:36:30 UTC 2012
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))))
More information about the cffi-objects-cvs
mailing list