[gambit-list] FFI

Marc Feeley feeley at iro.umontreal.ca
Wed May 20 23:31:47 EDT 2009


On 19-May-09, at 10:26 PM, FFT wrote:

> I asked this in comp.lang.scheme already:
>
> Is it possible to declare C types that are structs that include arrays
> (not pointers)? Also, what about bit fields?
>
> The answer I got in comp.lang.scheme is that one needs to use lists of
> strings (?!) for the former. Perhaps I'm missing something, but this
> seems to be very kludgy, even if it does work. Structs that have
> arrays are pretty common in C APIs (Bit fields happen too) What's the
> best approach here?


I'm not sure this answers your question... but the code below defines  
a c-define-struct
macro which simplifies interfacing to C structs.

Do you have an example of the kind of C struct you want to interface to?

Marc

;; File: "c-define-struct.scm"

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

;; Defines the c-define-struct macro, which extends the Gambit FFI to
;; interface to C structures.

(define-macro (c-define-struct type . fields)
   (let* ((type-str
           (symbol->string type))
          (sym
           (lambda strs (string->symbol (apply string-append strs))))
          (struct-type-str
           (string-append "struct " type-str))
          (struct-type*-str
           (string-append struct-type-str "*"))
          (release-type-str
           (string-append "release_" type-str))
          (type*
           (sym type-str "*"))
          (type*/nonnull
           (sym type-str "*/nonnull"))
          (type*/release-rc
           (sym type-str "*/release-rc"))
          (expansion
           `(begin

              ;; Define the release function which is called when the
              ;; object is no longer accessible from the Scheme world.

              (c-declare
               ,(string-append
                 "static ___SCMOBJ " release-type-str "( void* ptr )\n"
                 "{\n"
                 "  ___EXT(___release_rc)( ptr );\n"
                 "  return ___FIX(___NO_ERR);\n"
                 "}\n"))

              ;; Define the C types.

              (c-define-type ,type (struct ,type-str))
              (c-define-type ,type* (pointer ,type (,type*)))
              (c-define-type ,type*/nonnull (nonnull-pointer ,type  
(,type*)))
              (c-define-type ,type*/release-rc (nonnull-pointer ,type  
(,type*) ,release-type-str))

              ;; Define type allocator procedure.

              (define ,(sym "alloc-" type-str)
                (c-lambda ()
                          ,type*/release-rc
                          ,(string-append "___result_voidstar =  
___EXT(___alloc_rc)( sizeof( " struct-type-str " ) );")))

              ;; Define field getters.

              ,@(map (lambda (field-spec)
                       (let* ((field (car field-spec))
                              (field-str (symbol->string field))
                              (field-type (cadr field-spec)))
                         `(define ,(sym type-str "-" field-str)
                            (c-lambda (,type*/nonnull)
                                      ,field-type
                                      ,(string-append "___result =  
___arg1->" field-str ";")))))
                     fields)

              ;; Define field setters.

              ,@(map (lambda (field-spec)
                       (let* ((field (car field-spec))
                              (field-str (symbol->string field))
                              (field-type (cadr field-spec)))
                         `(define ,(sym type-str "-" field-str "-set!")
                            (c-lambda (,type*/nonnull ,field-type)
                                      void
                                      ,(string-append "___arg1->"  
field-str " = ___arg2;")))))
                     fields))))

     (if #t ;; change to #f if not debugging
         (pp `(definition:
               (c-define-struct ,type , at fields)
               expansion:
               ,expansion)))

     expansion))

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

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

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

(c-declare "struct pt { int x; int y; };")

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

(c-define-struct pt
   (x int)
   (y int)
)

;; The previous call to c-define-struct expands to the following
;; definitions.

;; (begin
;;
;;   (c-declare
;;    "static ___SCMOBJ release_pt( void* ptr )
;;     {
;;       ___EXT(___release_rc)( ptr );
;;       return ___FIX(___NO_ERR);
;;     }")
;;
;;   (c-define-type pt (struct "pt"))
;;   (c-define-type pt* (pointer pt (pt*)))
;;   (c-define-type pt*/nonnull (nonnull-pointer pt (pt*)))
;;   (c-define-type pt*/release-rc (nonnull-pointer pt (pt*)  
"release_pt"))
;;
;;   (define alloc-pt
;;     (c-lambda
;;      ()
;;      pt*/release-rc
;;      "___result_voidstar = ___EXT(___alloc_rc)( sizeof( struct  
pt ) );"))
;;
;;   (define pt-x (c-lambda (pt*/nonnull) int "___result = ___arg1- 
 >x;"))
;;   (define pt-y (c-lambda (pt*/nonnull) int "___result = ___arg1- 
 >y;"))
;;
;;   (define pt-x-set! (c-lambda (pt*/nonnull int) void "___arg1->x =  
___arg2;"))
;;   (define pt-y-set! (c-lambda (pt*/nonnull int) void "___arg1->y =  
___arg2;")))

;; Now let's define a user-friendly constructor procedure.

(define (make-pt x y)
   (let ((obj (alloc-pt)))
     (pt-x-set! obj x)
     (pt-y-set! obj y)
     obj))

(define p (make-pt 111 222))

(pp (list (pt-x p) (pt-y p)))

;; Demonstrate that the objects are automatically reclaimed by the
;; garbage collector (try running "top" in a different xterm and the
;; memory usage will stay constant).

(time
  (let loop ((n 10000000))
    (if (> n 0)
        (begin
          (make-pt n n)
          (loop (- n 1))))))

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




More information about the Gambit-list mailing list