summaryrefslogtreecommitdiff
path: root/libguile/foreign.c
diff options
context:
space:
mode:
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