[cffi-objects-cvs] r18 -
rklochkov at common-lisp.net
rklochkov at common-lisp.net
Sat Jan 12 21:26:46 UTC 2013
Author: rklochkov
Date: Sat Jan 12 13:26:46 2013
New Revision: 18
Log:
Added support for MESSAGE-OO and (lisp-name . c-name) syntax for structure fields
Modified:
cffi-objects.asd
freeable.lisp
package.lisp
struct.lisp
Modified: cffi-objects.asd
==============================================================================
--- cffi-objects.asd Mon Dec 31 05:35:32 2012 (r17)
+++ cffi-objects.asd Sat Jan 12 13:26:46 2013 (r18)
@@ -12,9 +12,9 @@
(defsystem cffi-objects
:description "CFFI in-place replacement with object wrappers, structs and arrays"
:author "Roman Klochkov <monk at slavsoft.surgut.ru>"
- :version "0.9"
+ :version "0.9.1"
:license "BSD"
- :depends-on (cffi trivial-garbage)
+ :depends-on (cffi trivial-garbage closer-mop)
:components
((:file package)
(:file redefines :depends-on (package freeable))
Modified: freeable.lisp
==============================================================================
--- freeable.lisp Mon Dec 31 05:35:32 2012 (r17)
+++ freeable.lisp Sat Jan 12 13:26:46 2013 (r18)
@@ -30,6 +30,7 @@
\begin{itemize}
\item [[freeable-base]] introduces all necessary fields and handlers
\item [[freeable]] have ready cffi-translator methods
+\end{itemize}
|#
(define-foreign-type freeable-base ()
@@ -55,9 +56,9 @@
This generic describes, how to free an object with CFFI type [[type]] and
pointer [[ptr]]. As [[type]] should be a symbol, you should specialize
this generic with EQL specifier if your objects shouldn't be freed with
-[[foreign-free].
+[[foreign-free]].
-One can ask, why normal specializer by type of object and [[object] as
+One can ask, why normal specializer by type of object and [[object]] as
a first parameter is not used. Such strange API is developed,
because [[free-ptr]] is used in [[trivial-garbage:finalize]] and in some
implementation (for example, SBCL) finalizer shouldn't have reference
@@ -69,19 +70,46 @@
(defgeneric free-ptr (type ptr)
(:documentation "Called to free ptr, unless overriden free-sent-ptr
-or free-returned-ptr. TYPE should be specialized with EQL")
+or free-returned-ptr. TYPE should be symbol and be specialized with EQL")
(:method (type ptr) (foreign-free ptr)))
;;;[ <generic free-sent-ptr>
+#|<doc>
+This generic describes, how to free an object with CFFI type [[type]] and
+pointer [[ptr]] after sending to foreign space. It has the same parameters
+as [[cffi:free-translated-object]]. If complex foreign type has additional
+conditionals or any additional actions when freeing, specialize it on you type.
+
+Please, don't call it directly. Use [[free-sent-if-needed]] instead.
+|#
+
(defgeneric free-sent-ptr (cffi-type ptr param)
+ (:documentation "Will be called in free-translated-object.
+CFFI-TYPE: type defined with define-foreign-type.
+PTR: foreign pointer
+PARAM: third parameter of free-translated-object ==
+ returned second value of translate-to-foreign.")
(:method ((cffi-type freeable-base) ptr param)
(unless (null-pointer-p ptr)
(free-ptr (type-of cffi-type) ptr))))
;;;[ <generic free-returned-ptr>
+#|<doc>
+This generic describes, how to free an object with CFFI type [[type]] and
+pointer [[ptr]] after receiving from foreign space. It has the same parameters
+as [[cffi:translate-to-foreign]]. If complex foreign type has additional
+conditionals or any additional actions when freeing, specialize it on you type.
+
+Please, don't call it directly. Use [[free-returned-if-needed]] instead.
+|#
+
+
(defgeneric free-returned-ptr (cffi-type ptr)
+ (:documentation "Will be called in translate-from-foreign after conversion.
+CFFI-TYPE: type defined with define-foreign-type.
+PTR: foreign pointer")
(:method ((cffi-type freeable-base) ptr)
(unless (null-pointer-p ptr)
(free-ptr (type-of cffi-type) ptr))))
@@ -89,22 +117,38 @@
;;;[ <function free-sent-if-needed
(defun free-sent-if-needed (cffi-type ptr param)
+ "This function should be placed in appropriate place of
+free-translated-object"
(when (fst-free-to-foreign-p cffi-type)
(free-sent-ptr cffi-type ptr param)))
;;;[ <function free-returned-if-needed
(defun free-returned-if-needed (cffi-type ptr)
+ "This function should be placed in appropriate place of
+translate-from-foreign"
(when (fst-free-from-foreign-p cffi-type)
(free-returned-ptr cffi-type ptr)))
;;;[ <class freeable>
+#|<doc>
+This is standard base class for freeable pointers. If you happy with
+default free algorithm, which implies, that [[free-sent-ptr]] is called after
+[[free-translated-object]] when type described with [[:free-to-foreign t]]
+and [[free-returned-ptr]] is called when type described with
+[[:free-from-foreign t]] after [[translate-from-foreign]].
+
+If you need more complicated logic (for example, to free object in
+translate-from-foreign, not after), you should inherit your class from
+[[freeable-base]] and
+call [[free-sent-if-needed]] from [[free-translated-object]]
+and [[free-returned-if-needed]] from [[translate-from-foreign]].
+|#
+
(defclass freeable (freeable-base) ()
(:documentation "Mixing to auto-set translators"))
-
-
(defmethod free-translated-object :after (ptr (type freeable) param)
(free-sent-if-needed type ptr param))
@@ -113,14 +157,39 @@
;;;[ <class freeable-out>
+#|<doc>
+This is standard base class for objects, that should be copied back
+to lisp after foreign function: so-called ``out parameters''.
+
+For every class, inherited from [[freeable-out]], you must
+implement method [[copy-from-foreign]].
+
+Then user of your class may set [[:out t]] in initargs for your class
+and be sure, that all changed data will be copied back to the variables.
+
+When implementing [[translate-to-foreign]] you must return (values ptr value),
+because second value will be passed to [[free-translated-object]], and then
+as PLACE to [[copy-from-foreign]].
+|#
+
(define-foreign-type freeable-out (freeable)
((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.
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"))
+;;;[ <generic copy-from-foreign>
+
+#|<doc>
+This generic must have an implementation for every class inherited from [[freeable-out]].
+|#
+
+(defgeneric copy-from-foreign (cffi-type ptr place)
+ (:documentation "Transfers data from pointer PTR to PLACE.
+CFFI-TYPE: type defined with define-foreign-type.
+PTR: foreign pointer
+PLACE: third parameter of free-translated-object ==
+ returned second value of translate-to-foreign"))
(defmethod free-translated-object :before (ptr (type freeable-out) place)
(when (object-out type)
Modified: package.lisp
==============================================================================
--- package.lisp Mon Dec 31 05:35:32 2012 (r17)
+++ package.lisp Sat Jan 12 13:26:46 2013 (r18)
@@ -24,7 +24,7 @@
(unexport (list v) p)))))
(defpackage #:cffi-objects
- (:use #:common-lisp #:cffi)
+ (:use #:common-lisp #:cffi #+message-oo #:message-oo)
(:export
#:freeable-base
;; slots
@@ -57,7 +57,6 @@
;; methods
#:free
-
#:*array-length*
;; types
#:pstring
@@ -74,19 +73,20 @@
#:cffi-string
#:struct
-; #:cffi-struct
+ #:cffi-struct
#:new-struct
#:free-struct
-
#:defcstruct-accessors
#:defcstruct*
#:defbitaccessors
+ ;; not for objects, but useful with cffi
#:with-foreign-out
#:with-foreign-outs
#:with-foreign-outs-list
+ ;; for creating object models on top of C objects
#:pair
#:setf-init
#:init-slots
@@ -136,6 +136,7 @@
to free foreign pointer, you should use [[foo-as-value]].
\include{redefines}
+\include{freeable}
|#
;;; </define>
Modified: struct.lisp
==============================================================================
--- struct.lisp Mon Dec 31 05:35:32 2012 (r17)
+++ struct.lisp Sat Jan 12 13:26:46 2013 (r18)
@@ -54,61 +54,104 @@
(defun pair (maybe-pair)
(if (consp maybe-pair) maybe-pair (cons maybe-pair maybe-pair)))
-(defmacro defcstruct-accessors (class)
+(defun slot-accessor (designator)
+ (flet ((count-args (list)
+ (do ((list list (cdr list))
+ (count 0 (1+ count)))
+ ((or (null list)
+ (char= (char (string (car list)) 0) #\&))
+ count))))
+ (let ((lambda-list
+ (closer-mop:generic-function-lambda-list (fdefinition designator))))
+ (= (count-args lambda-list) (if (listp designator) 2 1)))))
+
+(defmacro defaccessor (name c-name class &body body)
+ #-message-oo (declare (ignore c-name))
+ (let ((val* (when (listp name) (list 'val))))
+ `(progn
+ (unless (fboundp ',name)
+ (defgeneric ,name (, at val* ,class)))
+ (if (slot-accessor ',name)
+ (defmethod ,name (, at val* (,class ,class))
+ . ,body)
+ (warn 'style-warning
+ "~a is not a slot accessor" ',name))
+ #+message-oo
+ ,(if val*
+ `(defmessage ,class (,(alexandria:format-symbol
+ :keyword "~A=" c-name)
+ val)
+ . ,body)
+ `(defmessage ,class ,(alexandria:make-keyword c-name)
+ . ,body)))))
+
+
+(defmacro defcstruct-accessors (class &rest fields)
"CLASS may be symbol = class-name = struct name,
or may be cons (class-name . struct-name)"
(destructuring-bind (class-name . struct-name) (pair class)
`(progn
(clear-setters ,class-name)
,@(mapcar
- (lambda (x)
- `(progn
- (unless (fboundp ',x)
- (defgeneric ,x (,class-name)))
- (defmethod ,x ((,class-name ,class-name))
- (if (slot-boundp ,class-name 'value)
- (getf (slot-value ,class-name 'value) ',x)
- (foreign-slot-value (pointer ,class-name)
- ',(struct-type 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-type struct-name) ',x)
+ (lambda (field)
+ (destructuring-bind (lisp-name . c-name) (pair field)
+ `(progn
+ (defaccessor ,lisp-name ,c-name ,class-name
+ (if (slot-boundp ,class-name 'value)
+ (getf (slot-value ,class-name 'value) ',c-name)
+ (foreign-slot-value (pointer ,class-name)
+ ',(struct-type struct-name)
+ ',c-name)))
+ (defaccessor (setf ,lisp-name) ,c-name ,class-name
+ (if (slot-boundp ,class-name 'value)
+ (setf (getf (slot-value ,class-name 'value)
+ ',c-name)
+ val)
+ (setf (foreign-slot-value
+ (pointer ,class-name)
+ ',(struct-type struct-name) ',c-name)
val)))
- (save-setter ,class-name ,x)))
- (foreign-slot-names (struct-type struct-name))))))
+ (save-setter ,class-name ,lisp-name))))
+ (or (mapcan (lambda (field)
+ (unless (stringp field) (list (car field))))
+ fields)
+ (foreign-slot-names (struct-type struct-name)))))))
(defmacro defbitaccessors (class slot &rest fields)
(let ((pos 0))
(flet ((build-field (field)
(destructuring-bind (name type size) field
- (prog1
- `(progn
- (unless (fboundp ',name)
- (defgeneric ,name (,class)))
- (defmethod ,name ((,class ,class))
- (convert-from-foreign
- (ldb (byte ,size ,pos) (slot-value ,class ',slot))
- ,type))
- (unless (fboundp '(setf ,name))
- (defgeneric (setf ,name) (value ,class)))
- (defmethod (setf ,name) (value (,class ,class))
- (setf (ldb (byte ,size ,pos) (slot-value ,class ',slot))
- (convert-to-foreign value ,type))))
- (incf pos size)))))
+ (destructuring-bind (lisp-name . c-name) (pair name)
+ (prog1
+ `(progn
+ (defaccessor ,lisp-name ,c-name ,class
+ (convert-from-foreign
+ (ldb (byte ,size ,pos) (slot-value ,class ',slot))
+ ,type))
+ (defaccessor (setf ,lisp-name) ,c-name ,class
+ (setf (ldb (byte ,size ,pos)
+ (slot-value ,class ',slot))
+ (convert-to-foreign val ,type))))
+ (incf pos size))))))
(cons 'progn (mapcar #'build-field fields)))))
(defun parse-struct (body)
- (mapcar (lambda (str)
- (if (stringp str) str
- (let ((str2 (second str)))
- (if (and (consp str2) (eq (car str2) :struct))
- (list (first str) (struct-type (second str2)))
- str))))
- body))
+ (flet ((struct? (type)
+ (and (consp type) (eq (car type) :struct)))
+ (cname (name)
+ (destructuring-bind (lisp-name . c-name) (pair name)
+ (declare (ignore lisp-name))
+ c-name)))
+ (mapcar (lambda (str)
+ (if (stringp str) str
+ (list*
+ (cname (first str))
+ (let ((type (second str)))
+ (if (struct? type)
+ (struct-type (second type))
+ type))
+ (cddr str))))
+ body)))
(defmacro defcstruct* (class &body body)
`(progn
More information about the cffi-objects-cvs
mailing list