add subr-call VM op

* libguile/vm-i-system.c (subr_call): Add subr-call VM op.

diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 99c63819282a9e9c0863c262f75f6717b5baa8ff..546c9e09fa6c8069d429ede4cb71cf245bfcbe28 100644 (file)
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -886,6 +886,75 @@ VM_DEFINE_INSTRUCTION (55, tail_call, "tail-call", 1, -1, 1)
   goto vm_error_wrong_type_apply;
 }
 
+VM_DEFINE_INSTRUCTION (80, subr_call, "subr-call", 1, -1, -1)
+{
+  SCM foreign, ret;
+  SCM (*subr)();
+  nargs = FETCH ();
+  POP (foreign);
+
+  subr = SCM_FOREIGN_OBJECT_REF (foreign, void*);
+
+  VM_HANDLE_INTERRUPTS;
+  SYNC_REGISTER ();
+
+  switch (nargs)
+    {
+    case 0:
+      ret = subr ();
+      break;
+    case 1:
+      ret = subr (sp[0]);
+      break;
+    case 2:
+      ret = subr (sp[-1], sp[0]);
+      break;
+    case 3:
+      ret = subr (sp[-2], sp[-1], sp[0]);
+      break;
+    case 4:
+      ret = subr (sp[-3], sp[-2], sp[-1], sp[0]);
+      break;
+    case 5:
+      ret = subr (sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
+      break;
+    case 6:
+      ret = subr (sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
+      break;
+    case 7:
+      ret = subr (sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
+      break;
+    case 8:
+      ret = subr (sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
+      break;
+    case 9:
+      ret = subr (sp[-8], sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
+      break;
+    case 10:
+      ret = subr (sp[-9], sp[-8], sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]);
+      break;
+    default:
+      abort ();
+    }
+  
+  NULLSTACK_FOR_NONLOCAL_EXIT ();
+  DROPN (nargs + 1); /* drop args and procedure */
+      
+  if (SCM_UNLIKELY (SCM_VALUESP (ret)))
+    {
+      /* multiple values returned to continuation */
+      ret = scm_struct_ref (ret, SCM_INUM0);
+      nvalues = scm_ilength (ret);
+      PUSH_LIST (ret, scm_is_null);
+      goto vm_return_values;
+    }
+  else
+    {
+      PUSH (ret);
+      goto vm_return;
+    }
+}
+
 VM_DEFINE_INSTRUCTION (56, tail_call_nargs, "tail-call/nargs", 0, 0, 1)
 {
   SCM x;