From: Matt Birkholz Date: Wed, 19 Dec 2012 00:11:44 +0000 (-0700) Subject: Support callout struct and union parameter and return types. X-Git-Tag: release-9.2.0~202 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=cf1e855;p=mit-scheme.git Support callout struct and union parameter and return types. Requested by Peter Feigl . --- diff --git a/doc/ffi/ffi.texinfo b/doc/ffi/ffi.texinfo index 450006d9c..da6c87ece 100644 --- a/doc/ffi/ffi.texinfo +++ b/doc/ffi/ffi.texinfo @@ -359,13 +359,6 @@ A shim between Scheme and a C toolkit is specified by a case sensitive toolkit types, constants, and functions. Callback functions to be passed to the toolkit are also specified here. -There are some limitations on the C types that can be declared. -Basic, struct, union, enum and pointer types are allowed, but -bit-field members are not supported. C function parameters can be -basic, enum or pointer types. The return type of a C function is the -same plus @code{void}. Basically, no struct or union argument or -return types, at the moment. - Each top-level form in the C declaration file must look like one of these: @@ -375,14 +368,27 @@ these: (struct Name (Member @var{type}) @dots{}) (union Name (Member @var{type}) @dots{}) (enum @i{Name} (Member) @dots{}) -(extern @var{return-type} Name (param1 @var{arg-type}) @dots{}) -(callback @var{return-type} Name (param1 @var{arg-type}) @dots{}) +(extern @var{function-type} Name (param1 @var{arg-type}) @dots{}) +(callback @var{callback-type} Name (param1 @var{callback-arg-type}) @dots{}) @end smallexample -An enum's @i{@var{Name}} is optional. +The @code{include} expression includes another @file{.cdecl} file in +the current @file{.cdecl} file. The string argument is interpreted +relative to the current file's directory. + +@var{any} can be a @var{type} or the word @code{void}. + +@var{arg-type} can be any @var{type} @emph{except} anonymous structs +and unions. -@var{arg-type} is currently restricted to the following forms. It is -assumed that a lone @var{Name} is defined as a type on this list: +@var{function-type} can be any @var{arg-type} or @code{void}. + +@var{callback-arg-type} can be any @var{type} @emph{except} struct and +union types. + +@var{callback-type} can be any @var{callback-arg-type} or @code{void}. + +@var{type} can look like any of these: @smallexample Name @@ -390,36 +396,26 @@ Name (* @var{any}) (enum Name) (enum @i{Name} (Member) @dots{}) -@end smallexample - -@var{return-type} can be either @var{arg-type} or the word @code{void}. - -@var{basics} can be any of the words: @code{char}, @code{uchar}, -@code{short}, @code{ushort}, @code{int}, @code{uint}, @code{long}, -@code{ulong}, @code{float}, or @code{double} (all lowercase). - -@var{type} includes structs and unions: - -@smallexample -@var{arg-type} (struct Name) (struct @i{Name} (Member @var{type}) @dots{}) (union Name) (union @i{Name} (Member @var{type}) @dots{}) @end smallexample -@var{any} is any @var{type} @emph{or} @code{void}. +@var{Name} should be defined via a @code{typedef} form somewhere in +the (included) file(s). It does not have to be defined before it is +referenced. It does not have to be defined @emph{at all} if it is +only the target of a pointer type. -The @code{include} expression includes another @file{.cdecl} file in -the current @file{.cdecl} file. The string argument is interpreted -relative to the current file's directory. +@var{basics} can be any of the words: @code{char}, @code{uchar}, +@code{short}, @code{ushort}, @code{int}, @code{uint}, @code{long}, +@code{ulong}, @code{float}, or @code{double} (all lowercase). -While the informal grammar above allows anonymous structs to be -specified for argument or member types, they are of little use outside -top-level, @i{named} struct or union declarations. The peek and poke -(@code{C->} and @code{C->=}) syntax expects a type name (e.g. -@code{"GdkEventAny"} or @code{"struct _GdkEventAny"}) before any -member names. +While the informal grammar above allows anonymous structs to be member +types, they are useless outside a named type declaration. The peek +and poke (@code{C->} and @code{C->=}) syntaxes require a type name +(e.g. @code{"GdkEventAny"} or @code{"struct _GdkEventAny"}) before +any member names. @smallexample (C-include "prhello") @@ -509,12 +505,28 @@ alien function has cached the entry address, @code{call-alien} can invoke the trampoline (via @code{#[primitive c-call]}). The trampoline gets its arguments off the Scheme stack, converts them to C values, calls the C function, conses a result, and returns it to -Scheme. As a special case a function returning a pointer type -expects an extra first argument. If this argument is @code{#f}, the -return value is discarded. If the argument is an alien, the -function's return value clobbers the alien's address. This makes it -easy to grab pointers to toolkit resources without dropping them, or -avoid unnecessary consing of aliens. +Scheme. + +A function returning a pointer type is treated specially. +Its trampoline expects an extra (first) argument. +If the argument is @code{#f}, the return value is ignored. +If the argument is an alien, the function's return value clobbers the +alien's address. This makes it easy to grab pointers to toolkit +resources without dropping them, and to avoid unnecessary consing of +aliens. + +A function returning a struct or union type is treated similarly. +Its trampoline expects an extra (first) argument. +If the argument is @code{#f}, the return value is ignored. +If the argument is an alien, the returned struct or union is copied to +that address. + +Struct and union type parameters of a function are treated similarly. +The function's trampoline expects an alien argument for each such +parameter and copies the struct or union from the argument address +into a local variable. Callbacks currently cannot receive struct or +union type arguments, though they @emph{can} receive pointer type +arguments (consing an alien for each). The @code{alien-function} structures are fasdumpable. The caching mechanism invalidates the cache when a band is restored, or a diff --git a/src/ffi/ffi-test.c.stay b/src/ffi/ffi-test.c.stay index 8cd9d30d4..03dc76927 100644 --- a/src/ffi/ffi-test.c.stay +++ b/src/ffi/ffi-test.c.stay @@ -34,3 +34,17 @@ test_string (char *stri, TestStruct *stru) snprintf (s, 3, "%d", l1 + l2); return (s); } + +extern TestStruct +test_struct (TestStruct s) +{ + s.second += strlen (s.fourth); + return (s); +} + +extern TestUnion +test_union (TestUnion u) +{ + u.d += 1.0; + return (u); +} diff --git a/src/ffi/ffi-test.cdecl b/src/ffi/ffi-test.cdecl index 71bab5901..89023dfd6 100644 --- a/src/ffi/ffi-test.cdecl +++ b/src/ffi/ffi-test.cdecl @@ -9,6 +9,11 @@ (third char) (fourth (* char)))) +(typedef TestUnion + (union + (s TestStruct) + (d double))) + (extern double test_double (d double) (s (* TestStruct))) @@ -24,4 +29,10 @@ (callback double test_double_callback (d double) - (ID (* void))) \ No newline at end of file + (ID (* void))) + +(extern TestStruct test_struct + (s TestStruct)) + +(extern TestUnion test_union + (u TestUnion)) \ No newline at end of file diff --git a/src/ffi/ffi-test.h b/src/ffi/ffi-test.h index 215437925..bf74037b0 100644 --- a/src/ffi/ffi-test.h +++ b/src/ffi/ffi-test.h @@ -13,8 +13,16 @@ typedef struct { char * fourth; } TestStruct; +typedef union { + + TestStruct s; + double d; +} TestUnion; + typedef double (* TestDoubleCallback) (double d, void *user_data); extern double test_double (double d, TestStruct *s); extern char * test_string (char *c, TestStruct *s); extern void test_register_double (TestDoubleCallback callback, void *id); +extern TestStruct test_struct (TestStruct s); +extern TestUnion test_union (TestUnion u); diff --git a/src/ffi/generator.scm b/src/ffi/generator.scm index f03b7dda8..0c55c137e 100644 --- a/src/ffi/generator.scm +++ b/src/ffi/generator.scm @@ -185,11 +185,21 @@ Scm_"name" (void) (define (callout-return tos-var ret-var ret-ctype includes) (let ((ctype (definite-ctype ret-ctype includes))) (string-append - (if (ctype/void? ctype) - (string-append " - "ret-var"s = unspecific();") - (string-append " - "ret-var"s = "(callout-return-converter ctype)" ("ret-var");")) " + (cond ((ctype/void? ctype) + (string-append " + "ret-var"s = unspecific();")) + ((or (ctype/struct? ctype) (ctype/union? ctype)) + (let ((decl (decl-string ret-ctype))) + (string-append " + "ret-var"s = struct_to_scm (&"ret-var", sizeof("decl"));"))) + ((ctype/pointer? ctype) + (string-append " + "ret-var"s = pointer_to_scm ("ret-var");")) + ((or (ctype/basic? ctype) (ctype/enum? ctype)) + (let ((func (basic-scm-converter ctype))) + (string-append " + "ret-var"s = "func" ("ret-var");"))) + (else (error "Unexpected callout return type:" ctype ret-ctype))) " callout_pop ("tos-var"); return ("ret-var"s);"))) @@ -274,23 +284,22 @@ Scm_"name" (void) ((UCHAR USHORT UINT ULONG) "arg_ulong") ((FLOAT DOUBLE) "arg_double") (else (error "Unexpected parameter type:" arg-ctype)))) + ((or (ctype/struct? ctype) (ctype/union? ctype)) + (string-append "*("decl"*) arg_pointer")) (else (error "Unexpected parameter type:" arg-ctype))))) -(define (callout-return-converter ctype) +(define (basic-scm-converter ctype) ;; Returns the name of a C function that converts from the definite - ;; C type CTYPE to the analogous Scheme object. Note that the - ;; pointer converter, pointer_to_scm, returns pointers via c-call's - ;; second argument. - (cond ((ctype/pointer? ctype) "pointer_to_scm") - ((ctype/enum? ctype) "ulong_to_scm") + ;; C type CTYPE to the analogous Scheme object. + (cond ((ctype/enum? ctype) "ulong_to_scm") ((ctype/basic? ctype) (case ctype ((CHAR SHORT INT LONG) "long_to_scm") ((UCHAR USHORT UINT ULONG) "ulong_to_scm") ((FLOAT DOUBLE) "double_to_scm") ((VOID) #f) - (else (error "Unexpected return type:" ctype)))) - (else (error "Unexpected return type:" ctype)))) + (else (error "Unexpected C type:" ctype)))) + (else (error "Unexpected C type:" ctype)))) (define (callout-return-variable params) ;; Returns a name (string) for a variable that will hold the return @@ -464,10 +473,15 @@ Scm_"name" ("arglist") ;; Returns a function call that applies the appropriate Scheme ;; constructor to the ARG-CTYPE variable ARG-NAME. (let ((ctype (definite-ctype arg-ctype includes))) - (if (ctype/pointer? ctype) - (string-append "cons_alien((void*)"arg-name")") - (let ((func (callout-return-converter ctype))) - (string-append func"("arg-name")"))))) + (cond ((ctype/pointer? ctype) + (string-append "cons_alien((void*)"arg-name")")) + ((or (ctype/struct? ctype) (ctype/union? ctype)) + (error "Unsupported callback argument type:" arg-ctype arg-name)) + ((or (ctype/basic? ctype) (ctype/enum? ctype)) + (let ((func (basic-scm-converter ctype))) + (string-append func"("arg-name")"))) + (else + (error "Unexpected callback argument type:" arg-ctype arg-name))))) (define (callback-return-converter ret-type includes) ;; Returns the name of the C function that takes no arguments and @@ -482,8 +496,8 @@ Scm_"name" ("arglist") ((CHAR SHORT INT LONG) "long_value") ((UCHAR USHORT UINT ULONG) "ulong_value") ((FLOAT DOUBLE) "double_value") - (else (error "Unexpected return type:" ctype)))) - (else (error "Unexpected return type:" ctype))))) + (else (error "Unexpected callback return type:" ctype)))) + (else (error "Unexpected callback return type:" ctype))))) ;;; Groveler diff --git a/src/microcode/pruxffi.c b/src/microcode/pruxffi.c index 268f0182b..89e0e2118 100644 --- a/src/microcode/pruxffi.c +++ b/src/microcode/pruxffi.c @@ -885,6 +885,27 @@ pointer_to_scm (const void * p) return (SHARP_F); } +SCM +struct_to_scm (const void *p, int size) +{ + /* Return a struct or union from a callout. Expect the first real + argument (the 2nd) to be either #F or the alien address to + which the struct or union should be copied. */ + + SCM arg = ARG_REF (2); + if (arg == SHARP_F) + return (UNSPECIFIC); + if (is_alien (arg)) + { + memcpy(alien_address (arg), p, size); + return (arg); + } + + error_wrong_type_arg (2); + /* NOTREACHED */ + return (SHARP_F); +} + SCM cons_alien (const void * addr) { diff --git a/src/microcode/pruxffi.h b/src/microcode/pruxffi.h index 6e86140ec..cf445556b 100644 --- a/src/microcode/pruxffi.h +++ b/src/microcode/pruxffi.h @@ -76,6 +76,7 @@ extern SCM long_to_scm (const long i); extern SCM ulong_to_scm (const unsigned long i); extern SCM double_to_scm (const double d); extern SCM pointer_to_scm (const void* p); +extern SCM struct_to_scm (const void* p, int size); extern SCM cons_alien (const void* p); diff --git a/tests/ffi/test-ffi-wrapper.scm b/tests/ffi/test-ffi-wrapper.scm index b600b9ff5..59caba116 100644 --- a/tests/ffi/test-ffi-wrapper.scm +++ b/tests/ffi/test-ffi-wrapper.scm @@ -29,6 +29,18 @@ (new (c-peek-cstring alien))) (free alien) new)) + (let ((a (C-call "test_struct" struct struct))) + (assert-equal a struct) + (assert-equal (C-> a "TestStruct second") + (+ pi (string-length string)))) + (let ((union (begin + (set-alien/ctype! struct '|TestUnion|) + struct))) + (C->= union "TestUnion d" pi) + (let ((a (C-call "test_union" union union))) + (assert-equal a union) + (assert-equal (C-> a "TestUnion d") + (+ pi 1.0)))) (let ((ffi (->environment '(runtime ffi)))) (gc-flip) (assert-= (car ((access registered-callback-count ffi)))