This patch adds support for struct parameter and return types.
Functions that return a struct take an additional first alien
parameter (like functions returning pointers), which must point to a
memory area large enough to hold the struct data. This can for example
be allocated by MALLOC inside Scheme. Thus a struct is implicitly
converted to a struct*.
Functions that take a struct parameter actually assume a struct* as a
parameter, and internally copy the data into a struct that is passed to
the actual C function invocation.
This is not ideal, as extra memory needs to be allocated for structs,
however it allows to access such APIs, which isn't possible without
custom C wrapper functions without this patch (which would probably do
something similar).
---
src/ffi/generator.scm | 9 +++++++--
src/microcode/pruxffi.c | 22 ++++++++++++++++++++++
src/microcode/pruxffi.h | 1 +
3 files changed, 30 insertions(+), 2 deletions(-)
diff --git a/src/ffi/generator.scm b/src/ffi/generator.scm
index 1a4f098..c4774ea 100644
--- a/src/ffi/generator.scm
+++ b/src/ffi/generator.scm
@@ -189,7 +189,7 @@ Scm_"name" (void)
(string-append "
"ret-var"s = unspecific();")
(string-append "
- "ret-var"s = "(callout-return-converter ctype)" ("ret-var");")) "
+ "ret-var"s = "(callout-return-converter ctype)" ("(if (ctype/struct? ctype)
(string-append "&"ret-var",sizeof("(decl-string ret-ctype)")") ret-var)");")) "
callout_pop ("tos-var");
return ("ret-var"s);")))
@@ -214,7 +214,9 @@ Scm_"name" (void)
(define (callout-inits ret-ctype params includes)
;; Returns a multi-line string in C syntax for the Init section.
- (let* ((alien-ret-arg? (ctype/pointer? (definite-ctype ret-ctype includes)))
+ (let* ((alien-ret-arg? (let ((definite-ret-ctype (definite-ctype ret-ctype
includes)))
+ (or (ctype/pointer? definite-ret-ctype)
+ (ctype/struct? definite-ret-ctype))))
(nargs
;; (c-call 1:alien-function 2:ret-alien 3:arg1)
;; (c-call 1:alien-function 2:arg1)
@@ -274,6 +276,8 @@ Scm_"name" (void)
((UCHAR USHORT UINT ULONG) "arg_ulong")
((FLOAT DOUBLE) "arg_double")
(else (error "Unexpected parameter type:" arg-ctype))))
+ ((ctype/struct? ctype)
+ (string-append "*("decl"*) arg_pointer"))
(else (error "Unexpected parameter type:" arg-ctype)))))
(define (callout-return-converter ctype)
@@ -282,6 +286,7 @@ Scm_"name" (void)
;; pointer converter, pointer_to_scm, returns pointers via c-call's
;; second argument.
(cond ((ctype/pointer? ctype) "pointer_to_scm")
+ ((ctype/struct? ctype) "struct_to_scm")
((ctype/enum? ctype) "ulong_to_scm")
((ctype/basic? ctype)
(case ctype
diff --git a/src/microcode/pruxffi.c b/src/microcode/pruxffi.c
index 268f018..65d4cba 100644
--- a/src/microcode/pruxffi.c
+++ b/src/microcode/pruxffi.c
@@ -32,6 +32,7 @@ USA.
#include "history.h"
#include "floenv.h"
#include "pruxffi.h"
+#include "string.h"
/* Using SCM instead of SCHEME_OBJECT here, hoping to ensure that
these types always match. */
@@ -886,6 +887,27 @@ pointer_to_scm (const void * p)
}
SCM
+struct_to_scm (const void *p, int size)
+{
+ /* Return a pointer from a callout. Expect the first real argument
+ (the 2nd) to be either #F or an alien, which has enough memory
+ malloc'ed to hold the struct. */
+
+ 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)
{
/* Construct an alien. Used by callback kernels to construct
diff --git a/src/microcode/pruxffi.h b/src/microcode/pruxffi.h
index 6e86140..cf44555 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);
--
1.8.0.1
_______________________________________________
MIT-Scheme-devel mailing list
MIT-Scheme-devel@gnu.org
https://lists.gnu.org/mailman/listinfo/mit-scheme-devel
