summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/foreign.c133
-rw-r--r--libguile/foreign.h1
-rw-r--r--libguile/vm-i-system.c2
3 files changed, 135 insertions, 1 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
diff --git a/libguile/foreign.h b/libguile/foreign.h
index 8424cde4b..9bc047e65 100644
--- a/libguile/foreign.h
+++ b/libguile/foreign.h
@@ -118,6 +118,7 @@ SCM_INTERNAL void scm_i_foreign_print (SCM foreign, SCM port,
SCM_API SCM scm_make_foreign_function (SCM return_type, SCM func_ptr,
SCM arg_types);
+SCM_INTERNAL SCM scm_i_foreign_call (SCM foreign, SCM *argv);
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 3ddc7ea80..1c0aae5b6 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -959,7 +959,7 @@ VM_DEFINE_INSTRUCTION (58, foreign_call, "foreign-call", 1, -1, -1)
VM_HANDLE_INTERRUPTS;
SYNC_REGISTER ();
- ret = SCM_BOOL_F; /* scm_i_foreign_call (foreign, sp - nargs + 1); */
+ ret = scm_i_foreign_call (foreign, sp - nargs + 1);
NULLSTACK_FOR_NONLOCAL_EXIT ();