diff options
author | Andy Wingo <wingo@pobox.com> | 2009-12-01 21:59:42 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-12-01 21:59:42 +0100 |
commit | 23f276dea70668b7291589de1c7d7ea7ebd9026f (patch) | |
tree | 9efe3687daed1e4d3d09d9c9b26c919dffc9890d /libguile/vm.c | |
parent | 5161a3c0d7ec59e32a637bd093644a1a5b7b8dcf (diff) | |
download | guile-23f276dea70668b7291589de1c7d7ea7ebd9026f.tar.gz |
first step to make the vm stop calling the interpreter
* libguile/eval.h:
* libguile/eval.c (scm_closure_apply): New function, applies a closure.
Won't be necessary in the future, but for now here it is, with
internal linkage.
* libguile/gsubr.h:
* libguile/gsubr.c (scm_i_gsubr_apply_array): New function, applies a
gsubr to an array of values, potentially extending that array for
optional arguments and rest arguments and such.
* libguile/vm.c (apply_foreign): New function, applies a foreign
function to arguments on the stack, in place.
* libguile/vm-i-system.c (call): Add a case for procedures-with-setters
(will go away when they are applicable structs). Instead of calling
the evaluator for foreign functions, call apply_foreign.
Diffstat (limited to 'libguile/vm.c')
-rw-r--r-- | libguile/vm.c | 128 |
1 files changed, 128 insertions, 0 deletions
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) |