I am trying to create a binding for gobject library with CFFI. CFFI works extremely well, however I have a use case that is not covered by CFFI.
Basically, I want to define foreign types that should "clean up" after themselves when they are used as types for callback arguments. I have following use cases for this: 1) I want to have a structure created when callback is entered and have its contents copied to foreign structure when callback returns. 2) I want to have wrappers that contain a pointer to foreign structure. However, I want to ensure that operations on wrapper signal errors when callback returns (because pointer points to a stack-allocated structure). This is needed to ensure that no operations are done on invalid pointer. The attached patch provides suggested change: foreign types may specify that additional actions should be performed when the callback returns. This is achieved by adding new generic function CLEANUP-TRANSLATED-OBJECT-FOR- CALLBACK. Additional generic function HAS-CALLBACK-CLEANUP is called at macroexpansion time as an optimization to remove unnecessary calls to CLEANUP- TRANSLATED-OBJECT-FOR-CALLBACK. Attached is a test case that demonstrates the usage and checks for correctness of behavior. If there are obstacles for adding this patch, I would be happy to work on them.
diff -rN -u old-cffi/src/early-types.lisp new-cffi/src/early-types.lisp
--- old-cffi/src/early-types.lisp 2009-07-27 01:00:33.358581046 +0400
+++ new-cffi/src/early-types.lisp 2009-07-27 01:00:33.393581553 +0400
@@ -357,6 +357,14 @@
(:method (value type param)
(declare (ignore value type param))))
+;;; Execute actions when callback returns. VALUE is a value that was
+;;; translated by TRANSLATE-TO-FOREIGN and ORIGINAL-ARG is the canonical
+;;; foreign representation of value.
+(defgeneric cleanup-translated-object-for-callback (type value original-arg)
+ (:method (type value original-arg)
+ (declare (ignore type value original-arg))
+ nil))
+
;;;## Macroexpansion Time Translation
;;;
;;; The following EXPAND-* generic functions are similar to their
@@ -385,6 +393,14 @@
(declare (ignore value))
*runtime-translator-form*)
+;;; CLEANUP-TRANSLATED-OBJECT-FOR-CALLBACK
+
+;;; Checks whether the type has actions that should be performed at callback return.
+(defgeneric has-callback-cleanup (type)
+ (:method (type)
+ (declare (ignore type))
+ nil))
+
;;; EXPAND-TO-FOREIGN
;; The second return value is used to tell EXPAND-TO-FOREIGN-DYN that
diff -rN -u old-cffi/src/functions.lisp new-cffi/src/functions.lisp
--- old-cffi/src/functions.lisp 2009-07-27 01:00:33.358581046 +0400
+++ new-cffi/src/functions.lisp 2009-07-27 01:00:33.392580957 +0400
@@ -270,12 +270,24 @@
;;;# Defining Callbacks
+(defun expand-to-callback-cleanup (translated-arg original-arg type)
+ (when (has-callback-cleanup type)
+ `(cleanup-translated-object-for-callback ,type ,translated-arg ,original-arg))))
+
(defun inverse-translate-objects (args types declarations rettype call)
- `(let (,@(loop for arg in args and type in types
- collect (list arg (expand-from-foreign
- arg (parse-type type)))))
- ,@declarations
- ,(expand-to-foreign call (parse-type rettype))))
+ (let* ((sym-list (loop repeat (length args) collect (gensym)))
+ (parsed-types (loop for type in types collect (parse-type type)))
+ (cleanup-forms (loop for arg in args and type in parsed-types and sym in sym-list
+ collect (expand-to-callback-cleanup arg sym type))))
+ `(let (,@(loop for arg in args and type in types
+ collect (list arg (expand-from-foreign
+ arg (parse-type type))))
+ ,@(loop for arg in args and sym in sym-list and cleanup-form in cleanup-forms
+ when cleanup-form
+ collect (list sym arg)))
+ ,@declarations
+ (unwind-protect (progn ,(expand-to-foreign call (parse-type rettype)))
+ ,@(remove nil cleanup-forms)))))
(defun parse-defcallback-options (options)
(destructuring-bind (&key (calling-convention :cdecl)
diff -rN -u old-cffi/src/package.lisp new-cffi/src/package.lisp
--- old-cffi/src/package.lisp 2009-07-27 01:00:33.360581486 +0400
+++ new-cffi/src/package.lisp 2009-07-27 01:00:33.395580862 +0400
@@ -117,6 +117,8 @@
#:translate-to-foreign
#:translate-from-foreign
#:free-translated-object
+ #:cleanup-translated-object-for-callback
+ #:has-callback-cleanup
#:expand-to-foreign-dyn
#:expand-to-foreign
#:expand-from-foreign
(defpackage :cffi-test-case
(:use :cl :cffi)
(:export :test))
(in-package :cffi-test-case)
(defcstruct gdk-rectangle-cstruct
(x :int)
(y :int)
(width :int)
(height :int))
(defstruct gdk-rectangle
(x 0)
(y 0)
(width 0)
(height 0))
(define-foreign-type gdk-rectangle-type ()
()
(:actual-type :pointer)
(:simple-parser gdk-rectangle))
(defmethod translate-to-foreign (rectangle (type gdk-rectangle-type))
(let ((native-structure (foreign-alloc 'gdk-rectangle-cstruct)))
(loop
for slot in '(x y width height)
do (setf (foreign-slot-value native-structure 'gdk-rectangle-cstruct
slot)
(slot-value rectangle slot)))
(values native-structure rectangle)))
(defmethod free-translated-object (native-structure (type gdk-rectangle-type)
rectangle)
(loop
for slot in '(x y width height)
do (setf (slot-value rectangle slot)
(foreign-slot-value native-structure 'gdk-rectangle-cstruct
slot)))
(foreign-free native-structure))
(defmethod has-callback-cleanup ((type gdk-rectangle-type))
t)
(defmethod translate-from-foreign (native-structure (type gdk-rectangle-type))
(let ((rectangle (make-gdk-rectangle)))
(loop
for slot in '(x y width height)
do (setf (slot-value rectangle slot)
(foreign-slot-value native-structure 'gdk-rectangle-cstruct
slot)))
rectangle))
(defmethod cleanup-translated-object-for-callback ((type gdk-rectangle-type)
rectangle native-structure)
(loop
for slot in '(x y width height)
do (setf (foreign-slot-value native-structure 'gdk-rectangle-cstruct slot)
(slot-value rectangle slot))))
(defcallback incf-rectangle-callback :void
((rectangle gdk-rectangle) (delta :int))
(loop
for slot in '(x y width height)
do (incf (slot-value rectangle slot) delta)))
(defun incf-rectangle (r &optional (delta 1))
(foreign-funcall-pointer (callback incf-rectangle-callback) ()
gdk-rectangle r
:int delta
:void))
(defun test ()
(let ((r (make-gdk-rectangle :x 1 :y 2 :width 3 :height 4)))
(print r)
(incf-rectangle r 3)
(print r)
(and (= 4 (gdk-rectangle-x r))
(= 5 (gdk-rectangle-y r))
(= 6 (gdk-rectangle-width r))
(= 7 (gdk-rectangle-height r)))))
signature.asc
Description: This is a digitally signed message part.
_______________________________________________ cffi-devel mailing list cffi-devel@common-lisp.net http://common-lisp.net/cgi-bin/mailman/listinfo/cffi-devel
