Provide a C vararg interface to gsubr invocation.

* libguile/eval.i.c (CEVAL): Update calls to `scm_i_gsubr_apply ()' with
  a fixed number of arguments.  Use `scm_i_gsubr_apply_list ()' for
  calls with a list of arguments of unknown length.
  (SCM_APPLY): Use `scm_i_gsubr_apply_list ()' instead of
  `scm_i_gsubr_apply ()'.

* libguile/gsubr.c (gsubr_apply_raw): New.
  (scm_i_gsubr_apply): Change to take a C vararg list instead of a
  Scheme list.  Use `gsubr_apply_raw ()'.
  (scm_i_gsubr_apply_list): Use `gsubr_apply_raw ()'.

* libguile/gsubr.h (scm_i_gsubr_apply): Update prototype.
  (scm_i_gsubr_apply_list): New declaration.

3 files changed, 125 insertions, 29 deletions

diff --git a/libguile/eval.i.c b/libguile/eval.i.c
index de4851d4b..ae666d415 100644
--- a/libguile/eval.i.c
+++ b/libguile/eval.i.c
@@ -1129,7 +1129,7 @@ dispatch:
 	debug.info->a.proc = proc;
 	debug.info->a.args = SCM_EOL;
 #endif
-	RETURN (scm_i_gsubr_apply (proc, SCM_EOL));
+	RETURN (scm_i_gsubr_apply (proc, SCM_UNDEFINED));
       case scm_tc7_pws:
 	proc = SCM_PROCEDURE (proc);
 #ifdef DEVAL
@@ -1248,7 +1248,7 @@ dispatch:
 	    debug.info->a.args = scm_cons (arg1, debug.info->a.args);
 	    debug.info->a.proc = proc;
 #endif
-	    RETURN (scm_i_gsubr_apply (proc, scm_list_1 (arg1)));
+	    RETURN (scm_i_gsubr_apply (proc, arg1, SCM_UNDEFINED));
 	  case scm_tc7_pws:
 	    proc = SCM_PROCEDURE (proc);
 #ifdef DEVAL
@@ -1347,9 +1347,9 @@ dispatch:
 	    RETURN (SCM_SMOB_APPLY_2 (proc, arg1, arg2));
 	  case scm_tc7_gsubr:
 #ifdef DEVAL
-	    RETURN (scm_i_gsubr_apply (proc, debug.info->a.args));
+	    RETURN (scm_i_gsubr_apply_list (proc, debug.info->a.args));
 #else
-	    RETURN (scm_i_gsubr_apply (proc, scm_list_2 (arg1, arg2)));
+	    RETURN (scm_i_gsubr_apply (proc, arg1, arg2, SCM_UNDEFINED));
 #endif
 	  case scm_tcs_struct:
 	    if (SCM_OBJ_CLASS_FLAGS (proc) & SCM_CLASSF_PURE_GENERIC)
@@ -1479,7 +1479,7 @@ dispatch:
 	  RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
 				    SCM_CDDR (debug.info->a.args)));
 	case scm_tc7_gsubr:
-	  RETURN (scm_i_gsubr_apply (proc, debug.info->a.args));
+	  RETURN (scm_i_gsubr_apply_list (proc, debug.info->a.args));
 	case scm_tc7_pws:
 	  proc = SCM_PROCEDURE (proc);
 	  debug.info->a.proc = proc;
@@ -1542,10 +1542,15 @@ dispatch:
 	  RETURN (SCM_SMOB_APPLY_3 (proc, arg1, arg2,
 				    scm_ceval_args (x, env, proc)));
 	case scm_tc7_gsubr:
-	  RETURN (scm_i_gsubr_apply (proc,
-				     scm_cons2 (arg1, arg2,
-						scm_ceval_args (x, env,
-								proc))));
+	  if (scm_is_null (SCM_CDR (x)))
+	    /* 3 arguments */
+	    RETURN (scm_i_gsubr_apply (proc, arg1, arg2, EVALCAR (x, env),
+				       SCM_UNDEFINED));
+	  else
+	    RETURN (scm_i_gsubr_apply_list (proc,
+					    scm_cons2 (arg1, arg2,
+						       scm_ceval_args (x, env,
+								       proc))));
 	case scm_tc7_pws:
 	  proc = SCM_PROCEDURE (proc);
 	  if (!SCM_CLOSUREP (proc))
@@ -1864,7 +1869,7 @@ tail:
 #else
       args = (SCM_UNBNDP(arg1) ? SCM_EOL : scm_cons (arg1, args));
 #endif
-      RETURN (scm_i_gsubr_apply (proc, args));
+      RETURN (scm_i_gsubr_apply_list (proc, args));
     case scm_tc7_pws:
       proc = SCM_PROCEDURE (proc);
 #ifdef DEVAL
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index c6a1c5d2c..2b9a29dd1 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -21,6 +21,8 @@
 #endif
 
 #include <stdio.h>
+#include <stdarg.h>
+
 #include "libguile/_scm.h"
 #include "libguile/procprop.h"
 #include "libguile/root.h"
@@ -177,12 +179,114 @@ scm_c_define_gsubr_with_generic (const char *name,
   return create_gsubr_with_generic (1, name, req, opt, rst, fcn, gf);
 }
 
+/* Apply PROC, a gsubr, to the ARGC arguments in ARGV.  ARGC is expected to
+   match the number of arguments of the underlying C function.  */
+static SCM
+gsubr_apply_raw (SCM proc, unsigned int argc, const SCM *argv)
+{
+  SCM (*fcn) ();
+  unsigned int type, argc_max;
+
+  type = SCM_GSUBR_TYPE (proc);
+  argc_max = SCM_GSUBR_REQ (type) + SCM_GSUBR_OPT (type)
+    + SCM_GSUBR_REST (type);
+
+  if (SCM_UNLIKELY (argc != argc_max))
+    /* We expect the exact argument count.  */
+    scm_wrong_num_args (SCM_SNAME (proc));
 
+  fcn = SCM_SUBRF (proc);
+
+  switch (argc)
+    {
+    case 0:
+      return (*fcn) ();
+    case 1:
+      return (*fcn) (argv[0]);
+    case 2:
+      return (*fcn) (argv[0], argv[1]);
+    case 3:
+      return (*fcn) (argv[0], argv[1], argv[2]);
+    case 4:
+      return (*fcn) (argv[0], argv[1], argv[2], argv[3]);
+    case 5:
+      return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4]);
+    case 6:
+      return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
+    case 7:
+      return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
+		     argv[6]);
+    case 8:
+      return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
+		     argv[6], argv[7]);
+    case 9:
+      return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
+		     argv[6], argv[7], argv[8]);
+    case 10:
+      return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
+		     argv[6], argv[7], argv[8], argv[9]);
+    default:
+      scm_misc_error ((char *) SCM_SNAME (proc),
+		      "gsubr invocation with more than 10 arguments not implemented",
+		      SCM_EOL);
+    }
+
+  return SCM_BOOL_F; /* Never reached. */
+}
+
+/* Apply PROC, a gsubr, to the given arguments.  Missing optional arguments
+   are added, and rest arguments are turned into a list.  */
 SCM
-scm_i_gsubr_apply (SCM self, SCM args)
+scm_i_gsubr_apply (SCM proc, SCM arg, ...)
+{
+  unsigned int type, argc, argc_max;
+  SCM *argv;
+  va_list arg_list;
+
+  type = SCM_GSUBR_TYPE (proc);
+  argc_max = SCM_GSUBR_REQ (type) + SCM_GSUBR_OPT (type);
+  argv = alloca ((argc_max + SCM_GSUBR_REST (type)) * sizeof (*argv));
+
+  va_start (arg_list, arg);
+
+  for (argc = 0;
+       !SCM_UNBNDP (arg) && argc < argc_max;
+       argc++, arg = va_arg (arg_list, SCM))
+    argv[argc] = arg;
+
+  if (SCM_UNLIKELY (argc < SCM_GSUBR_REQ (type)))
+    scm_wrong_num_args (SCM_SNAME (proc));
+
+  /* Fill in optional arguments that were not passed.  */
+  while (argc < argc_max)
+    argv[argc++] = SCM_UNDEFINED;
+
+  if (SCM_GSUBR_REST (type))
+    {
+      /* Accumulate rest arguments in a list.  */
+      SCM *rest_loc;
+
+      argv[argc_max] = SCM_EOL;
+
+      for (rest_loc = &argv[argc_max];
+	   !SCM_UNBNDP (arg);
+	   rest_loc = SCM_CDRLOC (*rest_loc), arg = va_arg (arg_list, SCM))
+	*rest_loc = scm_cons (arg, SCM_EOL);
+
+      argc = argc_max + 1;
+    }
+
+  va_end (arg_list);
+
+  return gsubr_apply_raw (proc, argc, argv);
+}
+
+/* Apply SELF, a gsubr, to the arguments listed in ARGS.  Missing optional
+   arguments are added, and rest arguments are kept into a list.  */
+SCM
+scm_i_gsubr_apply_list (SCM self, SCM args)
 #define FUNC_NAME "scm_i_gsubr_apply"
 {
-  SCM (*fcn)() = SCM_SUBRF (self);
   SCM v[SCM_GSUBR_MAX];
   unsigned int typ = SCM_GSUBR_TYPE (self);
   long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ);
@@ -205,22 +309,8 @@ scm_i_gsubr_apply (SCM self, SCM args)
     v[i] = args;
   else if (!scm_is_null (args))
     scm_wrong_num_args (SCM_SNAME (self));
-  switch (n) {
-  case 2: return (*fcn)(v[0], v[1]);
-  case 3: return (*fcn)(v[0], v[1], v[2]);
-  case 4: return (*fcn)(v[0], v[1], v[2], v[3]);
-  case 5: return (*fcn)(v[0], v[1], v[2], v[3], v[4]);
-  case 6: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5]);
-  case 7: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6]);
-  case 8: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7]);
-  case 9: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8]);
-  case 10: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8], v[9]);
-  default:
-    scm_misc_error ((char *) SCM_SNAME (self),
-		    "gsubr invocation with more than 10 arguments not implemented",
-		    SCM_EOL);
-  }
-  return SCM_BOOL_F; /* Never reached. */
+
+  return gsubr_apply_raw (self, n, v);
 }
 #undef FUNC_NAME
 
diff --git a/libguile/gsubr.h b/libguile/gsubr.h
index 42a5c1886..65680a02c 100644
--- a/libguile/gsubr.h
+++ b/libguile/gsubr.h
@@ -48,7 +48,8 @@ SCM_API SCM scm_c_define_gsubr_with_generic (const char *name,
 					     int req, int opt, int rst,
 					     SCM (*fcn) (), SCM *gf);
 
-SCM_INTERNAL SCM scm_i_gsubr_apply (SCM proc, SCM args);
+SCM_INTERNAL SCM scm_i_gsubr_apply (SCM proc, SCM arg, ...);
+SCM_INTERNAL SCM scm_i_gsubr_apply_list (SCM proc, SCM args);
 SCM_INTERNAL void scm_init_gsubr (void);
 
 #endif  /* SCM_GSUBR_H */