summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--libguile/eval.c35
-rw-r--r--libguile/eval.h1
-rw-r--r--libguile/gsubr.c39
-rw-r--r--libguile/gsubr.h2
-rw-r--r--libguile/vm-i-system.c32
-rw-r--r--libguile/vm.c128
6 files changed, 224 insertions, 13 deletions
diff --git a/libguile/eval.c b/libguile/eval.c
index 4b8cc0af3..664d66217 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -539,6 +539,41 @@ apply (SCM proc, SCM args)
}
}
+SCM
+scm_closure_apply (SCM proc, SCM args)
+{
+ unsigned int nargs;
+ int nreq;
+ SCM env;
+
+ /* Args contains a list of all args. */
+ {
+ int ilen = scm_ilength (args);
+ if (ilen < 0)
+ scm_wrong_num_args (proc);
+ nargs = ilen;
+ }
+
+ nreq = SCM_CLOSURE_NUM_REQUIRED_ARGS (proc);
+ env = SCM_ENV (proc);
+ if (SCM_CLOSURE_HAS_REST_ARGS (proc))
+ {
+ if (SCM_UNLIKELY (scm_ilength (args) < nreq))
+ scm_wrong_num_args (proc);
+ for (; nreq; nreq--, args = CDR (args))
+ env = scm_cons (CAR (args), env);
+ env = scm_cons (args, env);
+ }
+ else
+ {
+ for (; scm_is_pair (args); args = CDR (args), nreq--)
+ env = scm_cons (CAR (args), env);
+ if (SCM_UNLIKELY (nreq != 0))
+ scm_wrong_num_args (proc);
+ }
+ return eval (SCM_CLOSURE_BODY (proc), env);
+}
+
scm_t_option scm_eval_opts[] = {
{ SCM_OPTION_INTEGER, "stack", 22000, "Size of thread stacks (in machine words)." },
diff --git a/libguile/eval.h b/libguile/eval.h
index f10110fb3..62b84c11b 100644
--- a/libguile/eval.h
+++ b/libguile/eval.h
@@ -76,6 +76,7 @@ SCM_API SCM scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args);
SCM_INTERNAL SCM scm_i_call_closure_0 (SCM proc);
SCM_API SCM scm_nconc2last (SCM lst);
SCM_API SCM scm_apply (SCM proc, SCM arg1, SCM args);
+SCM_INTERNAL SCM scm_closure_apply (SCM proc, SCM args);
#define scm_dapply(proc,arg1,args) scm_apply (proc, arg1, args)
SCM_API SCM scm_map (SCM proc, SCM arg1, SCM args);
SCM_API SCM scm_for_each (SCM proc, SCM arg1, SCM args);
diff --git a/libguile/gsubr.c b/libguile/gsubr.c
index 3b7315565..6123a0b1f 100644
--- a/libguile/gsubr.c
+++ b/libguile/gsubr.c
@@ -317,6 +317,45 @@ scm_i_gsubr_apply_list (SCM self, SCM args)
}
#undef FUNC_NAME
+/* Apply SELF, a gsubr, to the arguments in ARGS. Missing optional
+ arguments are added, and rest arguments are consed into a list. */
+SCM
+scm_i_gsubr_apply_array (SCM self, SCM *args, int nargs, int headroom)
+#define FUNC_NAME "scm_i_gsubr_apply"
+{
+ unsigned int typ = SCM_GSUBR_TYPE (self);
+ long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ);
+
+ if (SCM_UNLIKELY (nargs < SCM_GSUBR_REQ (typ)))
+ scm_wrong_num_args (SCM_SUBR_NAME (self));
+
+ if (SCM_UNLIKELY (headroom < n - nargs))
+ {
+ /* fallback on apply-list */
+ SCM arglist = SCM_EOL;
+ while (nargs--)
+ arglist = scm_cons (args[nargs], arglist);
+ return scm_i_gsubr_apply_list (self, arglist);
+ }
+
+ for (i = nargs; i < SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ); i++)
+ args[i] = SCM_UNDEFINED;
+
+ if (SCM_GSUBR_REST(typ))
+ {
+ SCM rest = SCM_EOL;
+ /* fallback on apply-list */
+ while (nargs-- >= n)
+ rest = scm_cons (args[nargs], rest);
+ args[n - 1] = rest;
+ }
+ else if (nargs > n)
+ scm_wrong_num_args (SCM_SUBR_NAME (self));
+
+ return gsubr_apply_raw (self, n, args);
+}
+#undef FUNC_NAME
+
#ifdef GSUBR_TEST
/* A silly example, taking 2 required args, 1 optional, and
diff --git a/libguile/gsubr.h b/libguile/gsubr.h
index 298181b15..e75658d1c 100644
--- a/libguile/gsubr.h
+++ b/libguile/gsubr.h
@@ -51,6 +51,8 @@ SCM_API SCM scm_c_define_gsubr_with_generic (const char *name,
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 SCM scm_i_gsubr_apply_array (SCM proc, SCM *args, int nargs,
+ int headroom);
SCM_INTERNAL void scm_init_gsubr (void);
#endif /* SCM_GSUBR_H */
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index a8fa2d3d3..5cfeab055 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -766,32 +766,38 @@ VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1)
sp[-nargs] = SCM_STRUCT_PROCEDURE (x);
goto vm_call;
}
+ else if (SCM_PROCEDURE_WITH_SETTER_P (x))
+ {
+ sp[-nargs] = SCM_PROCEDURE (x);
+ goto vm_call;
+ }
/*
* Other interpreted or compiled call
*/
if (!scm_is_false (scm_procedure_p (x)))
{
- SCM args;
+ SCM ret;
/* At this point, the stack contains the frame, the procedure and each one
of its arguments. */
- POP_LIST (nargs);
- POP (args);
- DROP (); /* drop the procedure */
- DROP_FRAME ();
-
SYNC_REGISTER ();
- PUSH (scm_apply (x, args, SCM_EOL));
+ ret = apply_foreign (sp[-nargs],
+ sp - nargs + 1,
+ nargs,
+ vp->stack_limit - sp + 1);
NULLSTACK_FOR_NONLOCAL_EXIT ();
- if (SCM_UNLIKELY (SCM_VALUESP (*sp)))
+ DROPN (nargs + 1); /* drop args and procedure */
+ DROP_FRAME ();
+
+ if (SCM_UNLIKELY (SCM_VALUESP (ret)))
{
/* truncate values */
- SCM values;
- POP (values);
- values = scm_struct_ref (values, SCM_INUM0);
- if (scm_is_null (values))
+ ret = scm_struct_ref (ret, SCM_INUM0);
+ if (scm_is_null (ret))
goto vm_error_not_enough_values;
- PUSH (SCM_CAR (values));
+ PUSH (SCM_CAR (ret));
}
+ else
+ PUSH (ret);
NEXT;
}
diff --git a/libguile/vm.c b/libguile/vm.c
index 055bbee4a..f9e4abe47 100644
--- a/libguile/vm.c
+++ b/libguile/vm.c
@@ -262,6 +262,134 @@ resolve_variable (SCM what, SCM program_module)
}
}
+static SCM
+apply_foreign (SCM proc, SCM *args, int nargs, int headroom)
+{
+ SCM arg1, arg2, arg3;
+
+ SCM_ASRTGO (SCM_NIMP (proc), badproc);
+
+ /* Parse args. */
+ switch (nargs)
+ {
+ case 0:
+ arg1 = SCM_UNDEFINED; arg2 = SCM_UNDEFINED; arg3 = SCM_UNDEFINED;
+ break;
+ case 1:
+ arg1 = args[0]; arg2 = SCM_UNDEFINED; arg3 = SCM_UNDEFINED;
+ break;
+ case 2:
+ arg1 = args[0]; arg2 = args[1]; arg3 = SCM_UNDEFINED;
+ break;
+ default:
+ arg1 = args[0]; arg2 = args[1]; arg3 = args[2];
+ break;
+ }
+
+ switch (SCM_TYP7 (proc))
+ {
+ case scm_tcs_closures:
+ /* FIXME: pre-boot closures should be smobs */
+ {
+ SCM arglist = SCM_EOL;
+ while (nargs--)
+ arglist = scm_cons (args[nargs], arglist);
+ return scm_closure_apply (proc, arglist);
+ }
+ case scm_tc7_subr_2o:
+ if (nargs > 2 || nargs < 1) scm_wrong_num_args (proc);
+ return SCM_SUBRF (proc) (arg1, arg2);
+ case scm_tc7_subr_2:
+ if (nargs != 2) scm_wrong_num_args (proc);
+ return SCM_SUBRF (proc) (arg1, arg2);
+ case scm_tc7_subr_0:
+ if (nargs != 0) scm_wrong_num_args (proc);
+ return SCM_SUBRF (proc) ();
+ case scm_tc7_subr_1:
+ if (nargs != 1) scm_wrong_num_args (proc);
+ return SCM_SUBRF (proc) (arg1);
+ case scm_tc7_subr_1o:
+ if (nargs > 1) scm_wrong_num_args (proc);
+ return SCM_SUBRF (proc) (arg1);
+ case scm_tc7_dsubr:
+ if (nargs != 1) scm_wrong_num_args (proc);
+ if (SCM_I_INUMP (arg1))
+ return scm_from_double (SCM_DSUBRF (proc) ((double) SCM_I_INUM (arg1)));
+ else if (SCM_REALP (arg1))
+ return scm_from_double (SCM_DSUBRF (proc) (SCM_REAL_VALUE (arg1)));
+ else if (SCM_BIGP (arg1))
+ return scm_from_double (SCM_DSUBRF (proc) (scm_i_big2dbl (arg1)));
+ else if (SCM_FRACTIONP (arg1))
+ return scm_from_double (SCM_DSUBRF (proc) (scm_i_fraction2double (arg1)));
+ SCM_WTA_DISPATCH_1 (*SCM_SUBR_GENERIC (proc), arg1,
+ SCM_ARG1, scm_i_symbol_chars (SCM_SUBR_NAME (proc)));
+ case scm_tc7_cxr:
+ if (nargs != 1) scm_wrong_num_args (proc);
+ return scm_i_chase_pairs (arg1, (scm_t_bits) SCM_SUBRF (proc));
+ case scm_tc7_subr_3:
+ if (nargs != 3) scm_wrong_num_args (proc);
+ return SCM_SUBRF (proc) (arg1, arg2, arg3);
+ case scm_tc7_lsubr:
+ {
+ SCM arglist = SCM_EOL;
+ while (nargs--)
+ arglist = scm_cons (args[nargs], arglist);
+ return SCM_SUBRF (proc) (arglist);
+ }
+ case scm_tc7_lsubr_2:
+ if (nargs < 2) scm_wrong_num_args (proc);
+ {
+ SCM arglist = SCM_EOL;
+ while (nargs-- > 2)
+ arglist = scm_cons (args[nargs], arglist);
+ return SCM_SUBRF (proc) (arg1, arg2, arglist);
+ }
+ case scm_tc7_asubr:
+ if (nargs < 2)
+ return SCM_SUBRF (proc) (arg1, SCM_UNDEFINED);
+ {
+ int idx = 1;
+ while (nargs-- > 1)
+ arg1 = SCM_SUBRF (proc) (arg1, args[idx++]);
+ return arg1;
+ }
+ case scm_tc7_rpsubr:
+ {
+ int idx = 0;
+ while (nargs-- > 1)
+ { idx++;
+ if (scm_is_false (SCM_SUBRF (proc) (args[idx-1], args[idx])))
+ return SCM_BOOL_F;
+ }
+ return SCM_BOOL_T;
+ }
+ case scm_tc7_smob:
+ if (!SCM_SMOB_APPLICABLE_P (proc))
+ goto badproc;
+ switch (nargs)
+ {
+ case 0:
+ return SCM_SMOB_APPLY_0 (proc);
+ case 1:
+ return SCM_SMOB_APPLY_1 (proc, arg1);
+ case 2:
+ return SCM_SMOB_APPLY_2 (proc, arg1, arg2);
+ default:
+ {
+ SCM arglist = SCM_EOL;
+ while (nargs-- > 2)
+ arglist = scm_cons (args[nargs], arglist);
+ return SCM_SMOB_APPLY_3 (proc, arg1, arg2, arglist);
+ }
+ }
+ case scm_tc7_gsubr:
+ return scm_i_gsubr_apply_array (proc, args, nargs, headroom);
+ default:
+ badproc:
+ scm_wrong_type_arg ("apply", SCM_ARG1, proc);
+ }
+}
+
#define VM_DEFAULT_STACK_SIZE (64 * 1024)