diff --git a/doc/guide/ffi.md b/doc/guide/ffi.md index 8c2e0ec54..73008e615 100644 --- a/doc/guide/ffi.md +++ b/doc/guide/ffi.md @@ -2,14 +2,16 @@ This is a quick guide to help you with your first FFI steps with Gerbil. -The first thing to note is that FFI in Gerbil is actually delegated to Gambit, where the mechanism to interface with C is known as the C-interface. -See the [Gambit manual](https://www.iro.umontreal.ca/~gambit/doc/gambit.html#C_002dinterface) for more information. +The first thing to note is that FFI in Gerbil is actually delegated to Gambit, where the +mechanism to interface with C is known as the C-interface. It is therefor important to read +section [19. C-interface](https://www.iro.umontreal.ca/~gambit/doc/gambit.html#C_002dinterface) +of the Gambit manual for a complete detailing of the interface. -The primary mechanism for delegating code directly to gambit is the `begin-foreign` special form: +The primary mechanism for delegating code directly to Gambit is the `begin-foreign` special form: ``` (begin-foreign body ...) ``` -Using the form, the `body` is included unexpanded directly to the generated gambit code for compilation with gsc. +Using the form, the `body` is included unexpanded directly to the generated Gambit code for compilation with gsc. ## Basic FFI @@ -21,7 +23,7 @@ We'll start our foray with a basic example: we are going to query for the versio int main (void) { puts (gnu_get_libc_version ()); return 0; } ``` -We need to write a file module that will define and export an identifier get-glibc-version. Subsequently, we'll import that identifier and use it in the Gerbil runtime. +We need to write a file module that will define and export an identifier `get-glibc-version`. Subsequently, we'll import that identifier and use it in the Gerbil runtime. ``` # Create a gerbil.pkg file for our project @@ -38,7 +40,7 @@ $ cat > libc-version.ss <") @@ -101,85 +105,331 @@ Using `begin-ffi` the code would be written as following: If you want to find more about Gerbil FFI programming, the std lib sources for the [os package](https://github.com/vyzo/gerbil/tree/master/src/std/os) are a good starting point. -## Interfacing with c structs - -In order to make interfacing with c structs a bit easier, some macros are provided to be used -inside the begin-ffi block. - -Consider a c struct X with members a of type t1 and b of type t2. -In order to interface with such a struct, following methods are available inside the begin-ffi macro. - -### `(define-c-struct X)` - -*types created* -- X for struct -- X* for the pointer to the struct. this is the struct to which the configurable release - function is provided. If no release function is provided and struct contains string - members, then a c method (`_ffi_free`) is generated for the struct, which - performs the cleanup of strings as well as the pointers. If there are no string members, - we fallback to the default ffi_free. -- X-shallow-ptr* similar to X*, default release function ffi_free is associated - (this is only created if char-string is one of the members) -- X-borrowed-ptr* similat to X* but no release function - -*lambdas created* -- `X-ptr?` predicate for the struct types (uses foreign-tags) -- `malloc-X` calls malloc for the struct and returns a pointer to it -- `ptr->X` get the value of X from its pointer -- `(malloc-X-array N)` calls malloc for N * sizeof X and returns a pointer to it, the - returned pointer is of type X-shallow-ptr* if strings are present otherwise it is X* -- `(X-array-ref ptr i)` returns a pointer with offset i starting at ptr, the returned - pointer is of type X-borrowed-ptr* -- `(X-array-set! ptr i val-ptr)` sets the value of the pointer at offset i from ptr to - be val-ptr - - -### `(define-c-struct X ((a . t1) (b . t2)))` - -In addition to the types and lambdas defined above, following additional lambdas are provided: - -*lambdas created* -- `X-a-set!`, `X-b-set!` setters for member variables. - Special compatibility for string types is provided, - If a string is passed as the value, then we strdup the string and set that to the argument. - If the struct member is already pointing to another string, then that - string is freed and the member will now point to a new string. - The cleanup of such strings are handled by the generated `_ffi_free`, if - a custom release function is provided, care should be taken while freeing. - -- `X-a`, `X-b` accessor functions for struct members - -In order to export the created lamdas, simply include (struct X a b) in the begin-ffi: -`(begin-ffi (... (struct X a b) ...) ...)` - -### Sample usage: - -``` -(begin-ffi ((struct abc a b)) - (c-declare " -struct abc { - char* a; - char* b; - char* c; -}; +## Interfacing with C structs + +In order to make interfacing with C structs a bit easier, the macro `define-c-struct` +is provided to be used inside the `begin-ffi` block. It will create a number of Scheme +foreign types, allocation and utility procedures, as well as accessors for optionally +declared struct members. + +### Overview + +Consider a C struct `X` with members `a` of type `t1` and `b` of type `t2`. The most basic +usage of `define-c-struct` is to simply provide `struct-name` as a symbol matching the +structure's *tag* of `X`: + +```scheme +(c-declare " + +struct X { + t1 a; + t2 b; +} + +") + +(define-c-struct X) +``` + +Without speciying any members, the interface treats `X` as opaque, as no accessors are +generated. The following Scheme foreign types are generated by the macro: + +```scheme +(c-define-type X (struct "X" (X))) ; The struct type. + +; Pointer type to which the custom release function is provided: +(c-define-type X* (pointer X (X*) )) +; : +; "ffi_free" ; Default, no string members +; "_ffi_free" ; Generated when string members present +; "custom_release_function" ; User specified `release-function` + +; Similar to X*, but with no release function: +(c-define-type X-borrowed-ptr* (pointer X (X*))) + +; Similar to X*, but with release function of "ffi_free". +; (Only generated when string members present): +(c-define-type X-shallow-ptr* (pointer X (X*) "ffi_free")) +``` + +Note that in the case above, if `t1` or `t2` are string types, then a C function +"X_ffi_free" is generated and assigned as the release-function of the pointer type +to perform cleanup of strings in addition to the struct. Where a user specified +release-function is provided, as in the case below, it would take precedent, and +care should be taken to provide the neccessary cleanup. + +Furthermore, the following procedures are generated by the macro: + +```scheme +(X-ptr? foreign-obj) ; X Predicate test using `foreign-tags` +(malloc-X) ; malloc X and return a X* to it +(ptr->X x-ptr) ; Dereference a pointer to an X +(malloc-X-array n) ; malloc N * sizeof X + ; The returned pointer type is X-shallow-ptr* when string + ; members are present, otherwise the type is X* +(X-array-ref x-ptr i) ; Obtain an X-borrowed-ptr* with offset + ; `i` starting at `x-ptr` +(X-array-set! x-ptr i val-ptr) ; Set the value of `x-ptr` offset + ; by `i` to be `val-ptr` +``` + +Specifying members of the struct will additionally generate accessors for those members. +All members of the struct need not be specified. The below use of `define-c-struct` +refines the call above to specify an interest only in member `b`, along with the a user +defined `release-function` called "my_release_function": + +```scheme +(define-c-struct X ((b . t2)) "my_release_function") +``` + +This would generate the following accessors for member `b`: + +```scheme +(X-b x-ptr) ; Getter for member `b` +(X-b-set! x-ptr t2-val) ; Setter for member `b` +``` + +Special compatibility is provided for setting new values to members of string types. +New values are `strdup` before being set to the member. When the member is already +pointing to another string, it is freed prior to assigning the new value. + +In order to export the generated procedures, one would include `(struct X a b)` as an +'id' in the externs part of the `begin-ffi` form as follows: +```scheme +(begin-ffi (... (struct X a b) ...) ...) +``` + +### `typedef` Aliased Structs + +It is common for C structs to be aliased by `typedef`, and many times the structs +themselves are anonymous. On the C side of things, compilers are smart enough to +recognize that a struct tag and a typedef alias may be different names for the same +type. But without some extra help, the Scheme side of things has no way of knowing +about the compatibility of a foreign type representing the struct and one representing +the typedef by a different name. Expectedly, Gambit has a solution as part of its +C-interface, what it refers to as *"The optional tags field of foreign type +specifications,"* as detailed in section +[19.1 The Mapping of Types between C and Scheme](https://www.iro.umontreal.ca/~gambit/doc/gambit.html#mapping-of-types) +paragraph 5. + +With `define-c-struct`, an optional list of `compatible-tags` may be specified. This +has the effect of easing Scheme side foreign-object type checking (without completely +disabling it) and allows, for example, the generated accessors to operate on these +compatible types. + +In the following example, a struct detailing a cartesian `point` is aliased as `coords`: + +```scheme +(c-declare " + +// struct tag 'point' differs from typedef alias 'coords' +typedef struct point { + int x; + int y; +} coords; + +// Consider an inconsistant codebase, where functions may type their +// parameters and return values with both `struct point` and the +// typedef alias `coords`. + +coords *skew_coords(coords *c) { ... } +struct point *legacy_function(struct point *pnt) { ... } + ") - - (define-c-struct abc ((a . char-string) (b . char-string)))) ;; don't need to define all fields - -(def obj (malloc-abc)) - -(abc-a-set! obj "hello") -(abc-b-set! obj "scheme") +; Standard foreign-object type declaration for `coords`. +; Notice the addition of `point` and `points*` to the tags fields: +; It allows for a `point*` to be sent to `skew_coords`. +(c-define-type coords (type "coords" (coords point))) +(c-define-type coords* (pointer coords (coords* point*))) + +(define-c-struct point ; `point` matches C struct tag. + ((x . int) (y . int)) ; Declare accessors for both members. + #f (coords)) ; Specify 'coords' as a compatible C type: + ; It allows for accessors `point-x`, etc. to be used on `coords*`, + ; and for foreign-objects typed `coords*` to be passed to + ; `legacy_function`. +``` + +Because the foreign-object types for `coords` and `point` include eachother's type +as part of their *foreign tags,* it is accepted by the C-interface that objects of +these types be interchangable. + +Whether it is neccessary to deal with both a struct type and a typedef type, depends +on the C code being interfaced. If in the C code, function parameters and return +values are typed with both `struct point` and `coords`, a configuration like the +above is required. However, if the C code is careful to use only the alias type +for instance, as in the case with typedef anonymous structs, one may forego the +issue of compatible types all together as illustracted in the following refined +example: + +```scheme +(c-declare " + +// typedef anonymous struct, no struct tag given +typedef struct { + int x; + int y; +} coords; + +coords *skew_coords(coords *c) { ... } + +") + +; If one used the standard foreign-object type declaration for `coords`, +; it would be treated as an opaque object, without access to members. +;(c-define-type coords (type "coords")) +;(c-define-type coords* (pointer coords)) + +; Instead, configure `define-c-struct` to operate on the typedef alias: +(define-c-struct coords ; `coords` matches typedef alias. *!* + ((x . int) (y . int)) ; Declare accessors for both members. + #f #f #t) ; Set `as-typedef` to `#t` for anonymous struct. +``` + +As you can see the macro offers flexibility for providing access to C structs +with regards to the variety of ways they may be declared and used in C. + +### Sample + +In the following contrived sample 'point-polar.ss', three structs are used to illustrate features +of `define-c-struct`, and particularly foreign-object *compatible types*. Two +structs represent cartesian and polar coordinates, respectively. The third collects +formatted strings for a question and answer. The C function `point_to_polar` converts +a cartesian coordinate to a polar coordinate, while `print_q_and_a` takes references +to each of the three structs to output the formatted results. + +```scheme +package: sample + +(import :std/foreign) + +(export #t) -(abc-a obj) ;; => hello +(begin-ffi ((struct cartesian_coord x y) + (struct polar_coord r a) + (struct q_and_a q a) + point-to-polar + print-q-and-a) + + (c-declare #< +#include + +#define PI 3.141592654 + +// A typedef struct representing a cartesian coordinate. +typedef struct cartesian_coord { + double x; + double y; +} point; + +// A typedef struct representing a polar coordinate. +typedef struct polar_coord { + double r; + double a; +} polar; + +// A typedef anonymous struct representing +// a formatted question and answer. +typedef struct { + char* q; + char* a; +} q_and_a; + +// A function to convert a cartesian coordinate to +// a polar coordinate. +polar *point_to_polar(point *pnt) { + polar *plr = (polar *) malloc(sizeof(polar)); + plr->r = hypot(pnt->x, pnt->y); + plr->a = 0.0; + if(pnt->x == 0.0) { + if(pnt->y > 0.0) plr->a = PI / 2.0; + if(pnt->y < 0.0) plr->a = -PI / 2.0; + } else { + plr->a = atan2(pnt->y, pnt->x); + } + return plr; +} + +// A function to print out the question and answer +// to a cartesian to polar coordinate conversion. +void print_q_and_a(q_and_a *qa, struct cartesian_coord *pnt, struct polar_coord *plr) { + printf(qa->q, pnt->x, pnt->y); + printf(qa->a, plr->r, plr->a); +} + +c-declare-end + ) + + ; Foreign-object type declarations for `point` and `polar`. + ; Notice the addition of `cartesian_coord*` as a non-primary tag for + ; `point*`. This tells Scheme that a foreign-object tagged `cartesian_coord*` + ; is acceptable (and type compatible) where one of `point*` is expected. It + ; is what allows for `cc-ref` to be passed as an argument to `point-to-polar` + ; in the interactive session below. + (c-define-type point (type "point" (point cartesian_coord))) + (c-define-type point* (pointer point (point* cartesian_coord*))) + (c-define-type polar (type "polar" (polar polar_coord))) + (c-define-type polar* (pointer polar (polar* polar_coord*))) + + (define-c-struct cartesian_coord + ((x . double) (y . double)) + #f (point)) ; Likewise, `point` is specified as a compatible type where a + ; foreign-object tagged `cartesian_coord` is expected. Such is + ; the case with the generated accessors for this struct type. + + (define-c-struct polar_coord + ((r . double) (a . double)) + #f (polar)) ; `polar` is specified as a compatible type of `polar_coord`. + ; Similarly, it is what allows the generated accessors to + ; opperate on foreign-objects tagged `polar`, and for `polar-ref` + ; to be passed as an argument to `print_q_and_a`, as shown in + ; the interactive session below. + + (define-c-struct q_and_a ; `q_and_a` matches the typedef alias. *!* + ((q . char-string) (a . char-string)) + #f #f #t) ; Set `as-typedef` as #t for anonymous struct. + + ; Interface with the C functions. + (define-c-lambda point-to-polar (point*) polar* "point_to_polar") + (define-c-lambda print-q-and-a (q_and_a* cartesian_coord* polar_coord*) void "print_q_and_a")) +``` + +The following interactive session shows use of the interface defined above. + +``` +$ gxi +> (import :sample/point-polar) +> (import :std/foreign) +> (def cc-ref (malloc-cartesian_coord)) +> (foreign-tags cc-ref) +(cartesian_coord* point*) +> (cartesian_coord-x-set! cc-ref 12.) +> (cartesian_coord-y-set! cc-ref 5.) +> (def polar-ref (point-to-polar cc-ref)) +> (foreign-tags polar-ref) +(polar* polar_coord*) +> (polar_coord-r polar-ref) +13. +> (polar_coord-a polar-ref) +.3947911196997615 +> (def q&a (malloc-q_and_a)) +> (foreign-tags q&a) +(q_and_a*) +> (q_and_a-q-set! q&a "What are the polar coordinates of point (x = %.1lf, y = %.1lf)? \n") +> (q_and_a-a-set! q&a "The polar coordinates are (r = %.1lf, a = %.1lf). \n") +> (print-q-and-a q&a cc-ref polar-ref) +What are the polar coordinates of point (x = 12.0, y = 5.0)? +The polar coordinates are (r = 13.0, a = 0.4). ``` ## Interfacing with a custom C program This example shows how to compile and link a C module to a Gerbil module, in order to call functions and return constants from the former. -Consider there are a simple module written in C defining two functions, f1 and f2: +Consider a simple module written in C defining two functions, f1 and f2: ``` $ cat ffi-pi.h @@ -252,5 +502,3 @@ Gerbil v0.16-133-gfdfdcb5d on Gambit v4.9.3-1232-gbba388b8 > (= (f1) (f2 1.0)) #t ``` - - diff --git a/doc/reference/foreign.md b/doc/reference/foreign.md index 737f23997..f8e1c4abe 100644 --- a/doc/reference/foreign.md +++ b/doc/reference/foreign.md @@ -16,19 +16,140 @@ prelude-macros ... prelude-decls ... body ... - prelude-defs ... + prelude-defs ...) ``` ::: -The following prelude macros are available within the body: +### Prelude Macros + +The following prelude macros are made available within the body: ``` (define-c-lambda id args ret [name/code]) (define-const id) (define-const* id) (define-guard guard defn) (define-with-errno id ffi-id args) -(define-c-struct struct-name members release-function) +(define-c-struct struct-name members release-function compatible-tags as-typedef) +``` + +#### define-c-struct + +```scheme +(define-c-struct struct-name [members [release-function [compatible-tags [as-typedef]]]]) + +: + c-struct-tag: symbol ; Where symbol->string is the C structure tag + c-typedef-alias: symbol ; Where symbol->string is the C typedef alias (with as-typedef = #t) + +: + ( (member-name . sheme-notation-type) ... ) ; Any or all members need not be specified. + +: + #f ; The default, in which case "ffi_free" or, if string members are present, + ; "_ffi_free" will be configured as cleanup function called by the gc. + c-function-name: string ; The name of a custom C function handling cleanup. + +: + (c_type ...) ; Additional C type declarations, where symbol->string is a C type + ; compatible with the type defined by this struct. + +as-typedef: boolean ; Default is #f. Set to #t when struct-name describes a typedef alias. + ; This is the case for defining an anonymous struct via a typedef. ``` +The `define-c-struct` macro works to create the necessary Scheme foreign types, accessors, +and utility procedures useful for interfacing with C structs. It is operable on standard +structs, their compatible typedef alias', as well as typedef'd anonymous structs. + +In the case of interfacing with stand-alone and typedef aliased structs, `struct-name` +should be a symbol matching that of the C structure tag. Additionally, in the case of a +typedef aliased struct, if the struct tag and typedef alias are differently named, the +alias type (along with any other compatible type) may be specified in `compatible-tags`. +This will ease the Scheme side foreign-object type checking and allow, for example, the +generated accessors to operate on these compatible types. + +> Note that the use of 'tag' here in *'struct tag'* and *'compatible-tags'* are a +> clash of two completely different concepts. With *'struct tag'*, tag refers to the name +> given to the struct in C. A tag in the context of *'compatible-tags'*, are part of Gambit's +> solution of specifying compatible C types when working with its C-Interface mechanism. +> Without specifying compatible tags, the Scheme side of things has no way of knowing types +> defined by the struct and typedef are essentially the same. +> +> See Section [19.1 The Mapping of Types between C and Scheme](https://www.iro.umontreal.ca/~gambit/doc/gambit.html#mapping-of-types), +> paragraph 5: "The optional tags field of foreign type specifications..." for more details. + +In the case of interfacing with a typedef'd anonymous struct, `struct-name` should be a +symbol matching that of the C typedef alias, and additionally, `as-typedef` should be set +to `#t`. This interfacing method may also be used with typedef aliased structs which are +tagged (non-anonymous), where a Scheme side foreign struct type is not needed. + +`members` may be ommited, in which case one treats the struct as opaque. Furthermore, all +members need not be specified when not needed. + +Note that when `release-function` is not provided, a default cleanup function will be +configured. When there are no string members, the default cleanup function is "ffi_free" +(defined in Prelude Definitions). When string members are present, a cleanup function is +provided by the macro which includes release of string members. + +::: tip Example +```scheme +(import :std/foreign) +(export #t) + +(begin-ffi ((struct stand_alone i a) + (struct point x y) + (struct anonymous msg)) + + (c-declare #<_ffi_free` function is included, which apart from freeing the ptr also -cleans up any string member. +### Prelude Definitions The following definitions are included after the body: - ``` #ifndef ___HAVE_FFI_FREE #define ___HAVE_FFI_FREE -___SCMOBJ ffi_free (void *ptr) { ...} +___SCMOBJ ffi_free (void *ptr) { ... } #endif ``` diff --git a/src/std/foreign-test.ss b/src/std/foreign-test.ss index 937e1ff30..83116f8f6 100644 --- a/src/std/foreign-test.ss +++ b/src/std/foreign-test.ss @@ -1,5 +1,6 @@ (import :std/foreign - :std/test) + :std/test + (only-in :gerbil/gambit foreign-tags)) (export foreign-test) @@ -7,7 +8,12 @@ (struct abc a b) (struct foo a1 d2 str) (struct bar i j) - g) + g + (struct a_struct g h) + (struct anon_struct a b) + in-struct-out-alias + in-alias-out-struct + ) (c-declare " struct abc { char* a; @@ -26,6 +32,32 @@ struct bar { int i; int j; }; + +typedef struct a_struct { + int g; + int h; +} an_alias; + +typedef struct { + char* a; + char* b; + char* c; +} anon_struct; + +an_alias *in_struct_out_alias(struct a_struct *s) { + an_alias* a = (an_alias *) malloc(sizeof(an_alias)); + a->g = s->g; + a->h = 77; + return a; +} + +struct a_struct *in_alias_out_struct(an_alias *a) { + struct a_struct* s = (struct a_struct *) malloc(sizeof(struct a_struct)); + s->g = a->h; + s->h = a->g; + return s; +} + ") @@ -39,7 +71,18 @@ int j; (d2 . abc*) (str . char-string))) (define-c-struct bar ((i . int) - (j . int)))) + (j . int))) + + (c-define-type an-alias (type "an_alias" (an_alias a_struct))) + (c-define-type an-alias* (pointer an-alias (an_alias* a_struct*))) + (define-c-struct a_struct + ((g . int) (h . int)) + #f (an_alias)) + (define-c-struct anon_struct + ((a . char-string) (b . char-string)) + #f #f #t) + (define-c-lambda in-struct-out-alias (a_struct*) an-alias* "in_struct_out_alias") + (define-c-lambda in-alias-out-struct (an-alias*) a_struct* "in_alias_out_struct")) (define foreign-test (test-suite "test :std/foreign" @@ -62,7 +105,32 @@ int j; (check (abc-a obj) => test-str1) (check (abc-b obj) => test-str2) - (check (abc-ptr? obj) => #t)) + (check (abc-ptr? obj) => '(abc*))) + + (test-case "c struct compatible-tags" + (def in-struct (malloc-a_struct)) + (check (member 'an_alias* (foreign-tags in-struct)) => '(an_alias*)) + (a_struct-g-set! in-struct 99) + + (def out-alias (in-struct-out-alias in-struct)) + (check (a_struct-ptr? out-alias) => '(a_struct*)) + (check (a_struct-g out-alias) => (a_struct-g in-struct)) + (check (a_struct-h out-alias) => 77) + + (def out-struct (in-alias-out-struct out-alias)) + (check (a_struct-g out-struct) => (a_struct-h out-alias)) + (check (a_struct-h out-struct) => (a_struct-g in-struct))) + + (test-case "c struct as-typedef" + (def obj (malloc-anon_struct)) + + (anon_struct-a-set! obj test-str1) + (anon_struct-b-set! obj test-str2) + + (check (anon_struct-a obj) => test-str1) + (check (anon_struct-b obj) => test-str2) + + (check (anon_struct-ptr? obj) => '(anon_struct*))) (test-case "c struct array" diff --git a/src/std/foreign.ss b/src/std/foreign.ss index 61fcb26a2..a8695e29d 100644 --- a/src/std/foreign.ss +++ b/src/std/foreign.ss @@ -52,11 +52,16 @@ ;; If no cleanup function is provided, a c function is created _ffi_free ;; this function frees the struct pointer as well as any string members if ;; they were set. - (define-macro (define-c-struct struct #!optional (members '()) release-function) + ;; compatible-tags => list of symbols representing additional C type declarations compatible with struct + ;; This is usually the name of a typedef alias, when it differs from the C struct tag. + ;; as-typedef => set to #t when defining an anonymous typdef'd struct + ;; In this case, `struct` should be the name of the typedef alias. + (define-macro (define-c-struct struct #!optional (members '()) release-function compatible-tags as-typedef) (let* ((struct-str (symbol->string struct)) (struct-ptr (string->symbol (string-append struct-str "*"))) (shallow-ptr (string->symbol (string-append struct-str "-shallow-ptr*"))) (borrowed-ptr (string->symbol (string-append struct-str "-borrowed-ptr*"))) + (struct-keyword? (if as-typedef "" "struct ")) (string-types '(char-string nonull-char-string UTF-8-string nonnull-UTF-8-string UTF-16-string nonnull-UTF16-string)) @@ -78,7 +83,7 @@ (default-free-body (and string-compat-required? (string-append "___SCMOBJ " struct-str "_ffi_free (void *ptr) {" "\n" - "struct " struct-str " *obj = (struct " struct-str "*) ptr;" "\n" + struct-keyword? struct-str " *obj = (" struct-keyword? struct-str "*) ptr;" "\n" (apply string-append (map (lambda (m) (cond @@ -99,52 +104,54 @@ (string-compat-types (if string-compat-required? `((c-declare ,default-free-body) (c-define-type ,shallow-ptr - (pointer ,struct (,struct-ptr) "ffi_free"))) - '()))) - `(begin (c-define-type ,struct (struct ,struct-str)) + (pointer ,struct (,struct-ptr) "ffi_free"))) + '())) + (compatible-tags (or compatible-tags '())) + (ptr-tags (map (lambda (t) (string->symbol (string-append (symbol->string t) "*"))) compatible-tags))) + + `(begin (c-define-type ,struct (,(if as-typedef 'type 'struct) ,struct-str (,struct ,@compatible-tags))) (c-define-type ,struct-ptr - (pointer ,struct (,struct-ptr) ,release-function)) + (pointer ,struct (,struct-ptr ,@ptr-tags) ,release-function)) (c-define-type ,borrowed-ptr (pointer ,struct (,struct-ptr))) - ,@string-compat-types + ,@string-compat-types - (define ,(string->symbol (string-append struct-str "-ptr?")) + (define ,(string->symbol (string-append struct-str "-ptr?")) (lambda (obj) (and (foreign? obj) - (equal? (foreign-tags obj) (quote (,struct-ptr)))))) + (member (quote ,struct-ptr) (foreign-tags obj))))) ;; getter and setters ,@(apply append - (map (lambda (m) - (let* ((member-name (symbol->string (car m))) - (member-type (cdr m)) - (getter-name (string-append struct-str "-" member-name)) - (setter-body (cond - ((member member-type string-types) - (string-setter-body member-name)) - (else - (string-append - "___arg1->" member-name " = ___arg2;" "\n" - "___return;" "\n"))))) - `((define ,(string->symbol getter-name) - (c-lambda (,struct-ptr) ,member-type - ,(string-append - "___return(___arg1->" member-name ");"))) - - (define ,(string->symbol (string-append getter-name "-set!")) - (c-lambda (,struct-ptr ,member-type) void - ,setter-body))))) - members)) + (map (lambda (m) + (let* ((member-name (symbol->string (car m))) + (member-type (cdr m)) + (getter-name (string-append struct-str "-" member-name)) + (setter-body (cond + ((member member-type string-types) + (string-setter-body member-name)) + (else + (string-append + "___arg1->" member-name " = ___arg2;" "\n" + "___return;" "\n"))))) + `((define ,(string->symbol getter-name) + (c-lambda (,struct-ptr) ,member-type + ,(string-append "___return(___arg1->" member-name ");"))) + + (define ,(string->symbol (string-append getter-name "-set!")) + (c-lambda (,struct-ptr ,member-type) void + ,setter-body))))) + members)) ;; malloc (define ,(string->symbol (string-append "malloc-" struct-str)) (c-lambda () ,struct-ptr ,(string-append - "struct " struct-str "* var = (struct " struct-str " *) malloc(sizeof(struct " struct-str "));" "\n" + struct-keyword? struct-str "* var = (" struct-keyword? struct-str " *) malloc(sizeof(" struct-keyword? struct-str "));" "\n" "if (var == NULL)" "\n" " ___return (NULL);" "\n" - "memset(var, 0, sizeof(struct " struct-str "));" + "memset(var, 0, sizeof(" struct-keyword? struct-str "));" "___return(var);"))) (define ,(string->symbol (string-append "ptr->" struct-str)) @@ -155,10 +162,10 @@ (define ,(string->symbol (string-append "malloc-" struct-str "-array")) (c-lambda (unsigned-int32) ,(if string-compat-required? shallow-ptr struct-ptr) ,(string-append - "struct " struct-str " *arr_var=(struct " struct-str " *) malloc(___arg1*sizeof(struct " struct-str "));" "\n" + struct-keyword? struct-str " *arr_var=(" struct-keyword? struct-str " *) malloc(___arg1*sizeof(" struct-keyword? struct-str "));" "\n" "if (arr_var == NULL)" "\n" " ___return (NULL);" "\n" - "memset(arr_var, 0, ___arg1*sizeof(struct " struct-str "));" "\n" + "memset(arr_var, 0, ___arg1*sizeof(" struct-keyword? struct-str "));" "\n" "___return(arr_var);"))) ;; ref array