diff options
-rw-r--r-- | libguile/eval.c | 35 | ||||
-rw-r--r-- | libguile/eval.h | 1 | ||||
-rw-r--r-- | libguile/gsubr.c | 39 | ||||
-rw-r--r-- | libguile/gsubr.h | 2 | ||||
-rw-r--r-- | libguile/vm-i-system.c | 32 | ||||
-rw-r--r-- | libguile/vm.c | 128 |
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) |