[cffi-devel] Support for cleanup actions on arguments performed when callback returns

[Kalyanov Dmitry]

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.
-------------- next part --------------
A non-text attachment was scrubbed...
Name: callback-cleanup.patch
Type: text/x-patch
Size: 3313 bytes
Desc: not available
URL: <https://mailman.common-lisp.net/pipermail/cffi-devel/attachments/20090727/df733dce/attachment.bin>
-------------- next part --------------
(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)))))
-------------- next part --------------
A non-text attachment was scrubbed...
Name: signature.asc
Type: application/pgp-signature
Size: 198 bytes
Desc: This is a digitally signed message part.
URL: <https://mailman.common-lisp.net/pipermail/cffi-devel/attachments/20090727/df733dce/attachment.sig>