summaryrefslogtreecommitdiff
path: root/libguile/foreign.c
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2010-01-25 18:04:45 +0100
committerAndy Wingo <wingo@pobox.com>2010-01-26 22:56:41 +0100
commit4d9130a5b733e844e42f27f209e148fa64f731be (patch)
tree2e9694cd1d4495e1d40a88aa287ca9e678215f60 /libguile/foreign.c
parentd8b04f04e90882f3903092ea85038a9e3cd10d39 (diff)
downloadguile-4d9130a5b733e844e42f27f209e148fa64f731be.tar.gz
implement foreign-call
* libguile/foreign.h: * libguile/foreign.c (scm_i_foreign_call): New internal function, actually implementing foreign calls. Untested. * libguile/vm-i-system.c (foreign-call): Wire up the call to scm_i_foreign_call.
Diffstat (limited to 'libguile/foreign.c')
-rw-r--r--libguile/foreign.c133
1 files changed, 133 insertions, 0 deletions
diff --git a/libguile/foreign.c b/libguile/foreign.c
index e15f6d5aa..e147c3d30 100644
--- a/libguile/foreign.c
+++ b/libguile/foreign.c
@@ -684,7 +684,140 @@ cif_to_procedure (SCM cif, SCM func_ptr)
return ret;
}
+static void
+unpack (ffi_type *type, void *loc, SCM x)
+{
+ switch (type->type)
+ {
+ case FFI_TYPE_FLOAT:
+ *(float*)loc = scm_to_double (x);
+ break;
+ case FFI_TYPE_DOUBLE:
+ *(double*)loc = scm_to_double (x);
+ break;
+ case FFI_TYPE_UINT8:
+ *(scm_t_uint8*)loc = scm_to_uint8 (x);
+ break;
+ case FFI_TYPE_SINT8:
+ *(scm_t_int8*)loc = scm_to_int8 (x);
+ break;
+ case FFI_TYPE_UINT16:
+ *(scm_t_uint16*)loc = scm_to_uint16 (x);
+ break;
+ case FFI_TYPE_SINT16:
+ *(scm_t_int16*)loc = scm_to_int16 (x);
+ break;
+ case FFI_TYPE_UINT32:
+ *(scm_t_uint32*)loc = scm_to_uint32 (x);
+ break;
+ case FFI_TYPE_SINT32:
+ *(scm_t_int32*)loc = scm_to_int32 (x);
+ break;
+ case FFI_TYPE_UINT64:
+ *(scm_t_uint64*)loc = scm_to_uint64 (x);
+ break;
+ case FFI_TYPE_SINT64:
+ *(scm_t_int64*)loc = scm_to_int64 (x);
+ break;
+ case FFI_TYPE_STRUCT:
+ if (!SCM_FOREIGN_TYPED_P (x, VOID))
+ abort ();
+ if (SCM_FOREIGN_LEN (x) && SCM_FOREIGN_LEN (x) != type->size)
+ abort ();
+ memcpy (loc, SCM_FOREIGN_POINTER (x, void), type->size);
+ break;
+ case FFI_TYPE_POINTER:
+ if (!SCM_FOREIGN_TYPED_P (x, VOID))
+ abort ();
+ *(void**)loc = SCM_FOREIGN_POINTER (x, void);
+ break;
+ default:
+ abort ();
+ }
+}
+
+static SCM
+pack (ffi_type *type, void *loc)
+{
+ switch (type->type)
+ {
+ case FFI_TYPE_VOID:
+ return SCM_UNSPECIFIED;
+ case FFI_TYPE_FLOAT:
+ return scm_from_double (*(float*)loc);
+ case FFI_TYPE_DOUBLE:
+ return scm_from_double (*(double*)loc);
+ case FFI_TYPE_UINT8:
+ return scm_from_uint8 (*(scm_t_uint8*)loc);
+ case FFI_TYPE_SINT8:
+ return scm_from_int8 (*(scm_t_int8*)loc);
+ case FFI_TYPE_UINT16:
+ return scm_from_uint16 (*(scm_t_uint16*)loc);
+ case FFI_TYPE_SINT16:
+ return scm_from_int16 (*(scm_t_int16*)loc);
+ case FFI_TYPE_UINT32:
+ return scm_from_uint32 (*(scm_t_uint32*)loc);
+ case FFI_TYPE_SINT32:
+ return scm_from_int32 (*(scm_t_int32*)loc);
+ case FFI_TYPE_UINT64:
+ return scm_from_uint64 (*(scm_t_uint64*)loc);
+ case FFI_TYPE_SINT64:
+ return scm_from_int64 (*(scm_t_int64*)loc);
+ case FFI_TYPE_STRUCT:
+ {
+ void *mem = scm_malloc (type->size);
+ memcpy (mem, loc, type->size);
+ return scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
+ mem, type->size, free);
+ }
+ case FFI_TYPE_POINTER:
+ return scm_take_foreign_pointer (SCM_FOREIGN_TYPE_VOID,
+ *(void**)loc, 0, NULL);
+ default:
+ abort ();
+ }
+}
+
+SCM
+scm_i_foreign_call (SCM foreign, SCM *argv)
+{
+ /* FOREIGN is the pair that cif_to_procedure set as the 0th element of the
+ objtable. */
+ ffi_cif *cif;
+ void (*func)();
+ scm_t_uint8 *data;
+ void *rvalue;
+ void **args;
+ unsigned i;
+ scm_t_ptrdiff off;
+
+ cif = SCM_FOREIGN_POINTER (scm_car (foreign), ffi_cif);
+ func = SCM_FOREIGN_POINTER (scm_cdr (foreign), void);
+ /* arg pointers */
+ args = alloca (sizeof(void*) * cif->nargs);
+ /* arg values, then return type value */
+ data = alloca (ROUND_UP (cif->bytes, cif->rtype->alignment)
+ + cif->rtype->size);
+ /* unpack argv to native values, setting argv pointers */
+ off = 0;
+ for (i = 0; i < cif->nargs; i++)
+ {
+ off = ROUND_UP (off, cif->arg_types[i]->alignment);
+ args[i] = data + off;
+ unpack (cif->arg_types[i], args[i], argv[i]);
+ off += cif->arg_types[i]->size;
+ }
+ /* prep space for the return value */
+ off = ROUND_UP (off, cif->rtype->alignment);
+ rvalue = data + off;
+
+ /* off we go! */
+ ffi_call (cif, func, rvalue, args);
+
+ return pack (cif->rtype, rvalue);
+}
+
static void