From 766a841ca40a99d8ce4a793abe1825f4fc8a356b Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Wed, 7 Jul 2010 23:53:48 +0900
Subject: [PATCH] adding support for foreign functions taking up to 16
 arguments

---
 eval.c                   | 31 ++++++++++++++++++-------------
 include/chibi/eval.h     |  1 +
 include/chibi/features.h |  7 +++++++
 tools/genstubs.scm       |  4 ++--
 vm.c                     | 16 ++++++++++++++++
 5 files changed, 44 insertions(+), 15 deletions(-)

diff --git a/eval.c b/eval.c
index 26f1e450..baa28e8a 100644
--- a/eval.c
+++ b/eval.c
@@ -1222,20 +1222,25 @@ sexp sexp_make_opcode (sexp ctx, sexp self, sexp name, sexp op_class, sexp code,
 sexp sexp_make_foreign (sexp ctx, const char *name, int num_args,
                         int flags, sexp_proc1 f, sexp data) {
   sexp res;
-  if (num_args > 6) {
-    res = sexp_user_exception(ctx, NULL, "make-foreign: exceeded foreign arg limit",
-                              sexp_make_fixnum(num_args));
-  } else {
-    res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE);
-    sexp_opcode_class(res) = SEXP_OPC_FOREIGN;
+#if ! SEXP_USE_EXTENDED_FCALL
+  if (num_args > 6)
+    return sexp_user_exception(ctx, NULL, "make-foreign: exceeded foreign arg limit",
+                               sexp_make_fixnum(num_args));
+#endif
+  res = sexp_alloc_type(ctx, opcode, SEXP_OPCODE);
+  sexp_opcode_class(res) = SEXP_OPC_FOREIGN;
+#if SEXP_USE_EXTENDED_FCALL
+  if (num_args > 6)
+    sexp_opcode_code(res) = SEXP_OP_FCALLN;
+  else
+#endif
     sexp_opcode_code(res) = SEXP_OP_FCALL1+num_args-1;
-    if (flags & 1) num_args--;
-    sexp_opcode_num_args(res) = num_args;
-    sexp_opcode_flags(res) = flags;
-    sexp_opcode_name(res) = name;
-    sexp_opcode_data(res) = data;
-    sexp_opcode_func(res) = f;
-  }
+  if (flags & 1) num_args--;
+  sexp_opcode_num_args(res) = num_args;
+  sexp_opcode_flags(res) = flags;
+  sexp_opcode_name(res) = name;
+  sexp_opcode_data(res) = data;
+  sexp_opcode_func(res) = f;
   return res;
 }
 
diff --git a/include/chibi/eval.h b/include/chibi/eval.h
index 4f98010a..938bf7c0 100644
--- a/include/chibi/eval.h
+++ b/include/chibi/eval.h
@@ -62,6 +62,7 @@ enum sexp_opcode_names {
   SEXP_OP_FCALL4,
   SEXP_OP_FCALL5,
   SEXP_OP_FCALL6,
+  SEXP_OP_FCALLN,
   SEXP_OP_JUMP_UNLESS,
   SEXP_OP_JUMP,
   SEXP_OP_PUSH,
diff --git a/include/chibi/features.h b/include/chibi/features.h
index b8aed237..d1b0c5e8 100644
--- a/include/chibi/features.h
+++ b/include/chibi/features.h
@@ -96,6 +96,9 @@
 /*   heap, of course. */
 /* #define SEXP_USE_GLOBAL_SYMBOLS 1 */
 
+/* uncomment this to disable foreign function bindings with > 6 args */
+/* #define SEXP_USE_EXTENDED_FCALL 0 */
+
 /* uncomment this if you don't need flonum support */
 /*   This is only for EVAL - you'll still be able to read */
 /*   and write flonums directly through the sexp API. */
@@ -310,6 +313,10 @@
 #endif
 #endif
 
+#ifndef SEXP_USE_EXTENDED_FCALL
+#define SEXP_USE_EXTENDED_FCALL 1
+#endif
+
 #ifndef SEXP_USE_FLONUMS
 #define SEXP_USE_FLONUMS ! SEXP_USE_NO_FEATURES
 #endif
diff --git a/tools/genstubs.scm b/tools/genstubs.scm
index 70aa0a0d..114320b4 100755
--- a/tools/genstubs.scm
+++ b/tools/genstubs.scm
@@ -272,8 +272,8 @@
              (s-args '()))
       (cond
        ((null? ls)
-        (if (> i 6)
-            (error "FFI currently only supports up to 6 scheme args" func))
+        ;;(if (> i 6)
+        ;;    (error "FFI currently only supports up to 6 scheme args" func))
         (vector scheme-name c-name stub-name ret-type
                 (reverse results) (reverse c-args) (reverse s-args)))
        (else
diff --git a/vm.c b/vm.c
index f7544ddf..1ebad747 100644
--- a/vm.c
+++ b/vm.c
@@ -455,6 +455,10 @@ static sexp_uint_t sexp_restore_stack (sexp saved, sexp *current) {
 #include "opt/opcode_names.h"
 #endif
 
+#if SEXP_USE_EXTENDED_FCALL
+#include "opt/fcall.c"
+#endif
+
 sexp sexp_vm (sexp ctx, sexp proc) {
   sexp bc = sexp_procedure_code(proc), cp = sexp_procedure_vars(proc);
   sexp *stack = sexp_stack_data(sexp_context_stack(ctx));
@@ -692,6 +696,18 @@ sexp sexp_vm (sexp ctx, sexp proc) {
     ip += sizeof(sexp);
     sexp_check_exception();
     break;
+#if SEXP_USE_EXTENDED_FCALL
+  case SEXP_OP_FCALLN:
+    _ALIGN_IP();
+    sexp_context_top(ctx) = top;
+    i = sexp_opcode_num_args(_WORD0);
+    tmp1 = sexp_fcall(ctx, self, i, _WORD0);
+    top -= (i-1);
+    _ARG1 = tmp1;
+    ip += sizeof(sexp);
+    sexp_check_exception();
+    break;
+#endif
   case SEXP_OP_JUMP_UNLESS:
     _ALIGN_IP();
     if (stack[--top] == SEXP_FALSE)