Re: [gambit-list] FFI

21 Mai 2009

      On 21-May-09, at 2:33 AM, FFT wrote:
...
On Wed, May 20, 2009 at 8:31 PM, Marc Feeley  
<feeley@iro.umontreal.ca> wrote:
...
Do you have an example of the kind of C struct you want to  
interface to?
struct s1 {
   float x, y, z;
};
struct s2 {
   struct s1 coordinates[4];
   char name[5];
   int tag : 3;
   unsigned flag : 1;
   unsigned direction : 2;
};
I have improved c-define-struct.scm to support arrays embedded in  
structs.  Check the attached file.  Below is an example based on your  
structures.

Marc

;;;----------------------------------------------------------------------------

;; A test of the c-define-struct macro.

(include "c-define-struct.scm")

;; The following C struct declaration would normally come from a .h  
file.

(c-declare "

struct s1 {
    float x, y, z;
};

struct s2 {
    struct s1 coordinates[4];
    char name[5];
    int tag : 3;
    unsigned flag : 1;
    unsigned direction : 2;
};

")

;; Now use the c-define-struct macro to generate a Scheme interface.

(c-define-struct s1
   (x float)
   (y float)
   (z float)
)

(c-define-struct s2
   (coordinates (array s1))
   (name (array char))
   (tag int)
   (flag unsigned-int)
   (direction unsigned-int)
)

;; The previous calls to c-define-struct expand to the following
;; definitions.

;; (begin
;;
;;   (c-declare
;;    "static ___SCMOBJ release_s1( void* ptr )
;;     {
;;       ___EXT(___release_rc)( ptr );
;;       return ___FIX(___NO_ERR);
;;     }")
;;
;;   (c-define-type s1 (struct "s1"))
;;   (c-define-type s1* (pointer s1 (s1*)))
;;   (c-define-type s1*/nonnull (nonnull-pointer s1 (s1*)))
;;   (c-define-type s1*/release-rc (nonnull-pointer s1 (s1*)  
"release_s1"))
;;
;;   (define alloc-s1
;;     (c-lambda
;;      ()
;;      s1*/release-rc
;;      "___result_voidstar = ___EXT(___alloc_rc)( sizeof( struct  
s1 ) );"))
;;
;;   (define s1-x (c-lambda (s1*/nonnull) float "___result = ___arg1-
...
x;"))
;;   (define s1-x-set!
;;     (c-lambda (s1*/nonnull float) void "___arg1->x = ___arg2;"))
;;   (define s1-y (c-lambda (s1*/nonnull) float "___result = ___arg1- 
y;"))
;;   (define s1-y-set!
;;     (c-lambda (s1*/nonnull float) void "___arg1->y = ___arg2;"))
;;   (define s1-z (c-lambda (s1*/nonnull) float "___result = ___arg1- 
z;"))
;;   (define s1-z-set!
;;     (c-lambda (s1*/nonnull float) void "___arg1->z = ___arg2;")))
;;
;; (begin
;;
;;   (c-declare
;;    "static ___SCMOBJ release_s2( void* ptr )
;;     {
;;       ___EXT(___release_rc)( ptr );
;;       return ___FIX(___NO_ERR);
;;     }")
;;
;;   (c-define-type s2 (struct "s2"))
;;   (c-define-type s2* (pointer s2 (s2*)))
;;   (c-define-type s2*/nonnull (nonnull-pointer s2 (s2*)))
;;   (c-define-type s2*/release-rc (nonnull-pointer s2 (s2*)  
"release_s2"))
;;
;;   (define alloc-s2
;;     (c-lambda
;;      ()
;;      s2*/release-rc
;;      "___result_voidstar = ___EXT(___alloc_rc)( sizeof( struct  
s2 ) );"))
;;
;;   (define s2-coordinates-ref
;;     (c-lambda
;;      (s2*/nonnull int)
;;      s1*/nonnull
;;      "___result_voidstar = &___arg1->coordinates[___arg2];"))
;;   (define s2-name-ref
;;     (c-lambda (s2*/nonnull int) char "___result = ___arg1- 
name[___arg2];"))
;;   (define s2-name-set!
;;     (c-lambda
;;      (s2*/nonnull int char)
;;      void
;;      "___arg1->name[___arg2] = ___arg3;"))
;;   (define s2-tag (c-lambda (s2*/nonnull) int "___result = ___arg1- 
tag;"))
;;   (define s2-tag-set!
;;     (c-lambda (s2*/nonnull int) void "___arg1->tag = ___arg2;"))
;;   (define s2-flag
;;     (c-lambda (s2*/nonnull) unsigned-int "___result = ___arg1- 
flag;"))
;;   (define s2-flag-set!
;;     (c-lambda (s2*/nonnull unsigned-int) void "___arg1->flag =  
___arg2;"))
;;   (define s2-direction
;;     (c-lambda (s2*/nonnull) unsigned-int "___result = ___arg1- 
direction;"))
;;   (define s2-direction-set!
;;     (c-lambda
;;      (s2*/nonnull unsigned-int)
;;      void
;;      "___arg1->direction = ___arg2;")))
;; The procedure (s2-coordinates-ref s2-ptr i) returns a foreign
;; pointer to the s1 structure at index i in the coordinates array,
;; and (s2-name-ref s2-ptr i) returns the character at index i in the
;; name array.

;; IMPORTANT NOTE: the foreign pointer returned by s2-coordinates-ref
;; is a pointer to a C struct within another C struct (the
;; "container").  The foreign pointer is only valid as long as the
;; container is allocated.  Be wary that in the case of a C structure
;; allocated from Scheme, such as with a call to alloc-s2, the garbage
;; collector could reclaim the structure as soon as the foreign
;; pointer to it is dropped.

;; Now let's create some structs and access them.

(define (s1-init! coord x y z)
   (s1-x-set! coord x)
   (s1-y-set! coord y)
   (s1-z-set! coord z))

(define (s1-print coord)
   (pp (list (s1-x coord)
             (s1-y coord)
             (s1-z coord))))

(define p (alloc-s2))

(s1-init! (s2-coordinates-ref p 0) 1.0 2.0 3.0)
(s1-init! (s2-coordinates-ref p 1) 1.1 2.1 3.1)
(s1-init! (s2-coordinates-ref p 2) 1.2 2.2 3.2)
(s1-init! (s2-coordinates-ref p 3) 1.3 2.3 3.3)

(s2-name-set! p 0 #\a)
(s2-name-set! p 1 #\b)
(s2-name-set! p 2 #\c)
(s2-name-set! p 3 #\d)
(s2-name-set! p 4 #\e)

(s1-print (s2-coordinates-ref p 0))
(s1-print (s2-coordinates-ref p 1))
(s1-print (s2-coordinates-ref p 2))
(s1-print (s2-coordinates-ref p 3))

(pp (s2-name-ref p 2))

;;;----------------------------------------------------------------------------