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.

diff --git a/libguile/foreign.c b/libguile/foreign.c
index e15f6d5..e147c3d 100644 (file)
--- 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);
+}
+
 \f
 
 static void

diff --git a/libguile/foreign.h b/libguile/foreign.h
index 8424cde..9bc047e 100644 (file)
--- 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);
 
 \f
 

diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 3ddc7ea..1c0aae5 100644 (file)
--- 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 ();