diff options
author | Andy Wingo <wingo@pobox.com> | 2010-05-13 21:43:35 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-05-14 00:28:39 +0200 |
commit | 7572ee5261f434cf9b8e58126eb6d87c085a596d (patch) | |
tree | 3ea2ba086038f4e0ee8be0c6edfe82ffd765bad8 /libguile/eval.c | |
parent | d8a071fc4e709ee83cd3c7fc935f7ec21375e624 (diff) | |
download | guile-7572ee5261f434cf9b8e58126eb6d87c085a596d.tar.gz |
evaluator support for case-lambda
* libguile/memoize.c (patch_case_lambda, scm_m_case_lambda)
(scm_m_case_lambda_star): Add memoizers for case-lambda and
case-lambda*.
(unmemoize): Unmemoize lambdas with multiple arities.
* libguile/eval.c (prepare_boot_closure_env_for_apply):
(prepare_boot_closure_env_for_eval): Adapt to return both body and
env, so that case-lambda clauses can be selected appropriately.
(eval, boot_closure_apply): Adapt callers.
* module/ice-9/eval.scm (make-general-closure): Support multiple
arities.
Diffstat (limited to 'libguile/eval.c')
-rw-r--r-- | libguile/eval.c | 66 |
1 files changed, 42 insertions, 24 deletions
diff --git a/libguile/eval.c b/libguile/eval.c index ac004da55..7c2106023 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -124,9 +124,11 @@ static scm_t_bits scm_tc16_boot_closure; inits = CAR (mx); mx = CDR (mx); \ alt = CAR (mx); \ } while (0) -static SCM prepare_boot_closure_env_for_apply (SCM proc, SCM args); -static SCM prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc, - SCM exps, SCM env); +static void prepare_boot_closure_env_for_apply (SCM proc, SCM args, + SCM *out_body, SCM *out_env); +static void prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc, + SCM exps, SCM *out_body, + SCM *inout_env); #define CAR(x) SCM_CAR(x) @@ -270,8 +272,7 @@ eval (SCM x, SCM env) * ARGS is the list of arguments. */ if (BOOT_CLOSURE_P (proc)) { - x = BOOT_CLOSURE_BODY (proc); - env = prepare_boot_closure_env_for_apply (proc, args); + prepare_boot_closure_env_for_apply (proc, args, &x, &env); goto loop; } else @@ -285,8 +286,7 @@ eval (SCM x, SCM env) if (BOOT_CLOSURE_P (proc)) { - x = BOOT_CLOSURE_BODY (proc); - env = prepare_boot_closure_env_for_eval (proc, argc, mx, env); + prepare_boot_closure_env_for_eval (proc, argc, mx, &x, &env); goto loop; } else @@ -900,8 +900,9 @@ scm_apply (SCM proc, SCM arg1, SCM args) return scm_vm_apply (scm_the_vm (), proc, args); } -static SCM -prepare_boot_closure_env_for_apply (SCM proc, SCM args) +static void +prepare_boot_closure_env_for_apply (SCM proc, SCM args, + SCM *out_body, SCM *out_env) { int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc); SCM env = BOOT_CLOSURE_ENV (proc); @@ -913,6 +914,8 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args) scm_wrong_num_args (proc); for (; scm_is_pair (args); args = CDR (args)) env = scm_cons (CAR (args), env); + *out_body = BOOT_CLOSURE_BODY (proc); + *out_env = env; } else if (BOOT_CLOSURE_IS_REST (proc)) { @@ -921,26 +924,35 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args) for (; nreq; nreq--, args = CDR (args)) env = scm_cons (CAR (args), env); env = scm_cons (args, env); + *out_body = BOOT_CLOSURE_BODY (proc); + *out_env = env; } else { int i, argc, nreq, nopt; SCM body, rest, kw, inits, alt; + loop: BOOT_CLOSURE_PARSE_FULL (proc, body, nargs, rest, nopt, kw, inits, alt); argc = scm_ilength (args); if (argc < nreq) { if (scm_is_true (alt)) - abort (); + { + proc = alt; + goto loop; + } else scm_wrong_num_args (proc); } if (scm_is_false (kw) && argc > nreq + nopt && scm_is_false (rest)) { if (scm_is_true (alt)) - abort (); + { + proc = alt; + goto loop; + } else scm_wrong_num_args (proc); } @@ -1035,14 +1047,15 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args) } } } - } - return env; + *out_body = BOOT_CLOSURE_BODY (proc); + *out_env = env; + } } -static SCM +static void prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc, - SCM exps, SCM env) + SCM exps, SCM *out_body, SCM *inout_env) { int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc); SCM new_env = BOOT_CLOSURE_ENV (proc); @@ -1051,40 +1064,44 @@ prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc, && !BOOT_CLOSURE_HAS_REST_ARGS (proc))) { for (; scm_is_pair (exps); exps = CDR (exps), nreq--) - new_env = scm_cons (eval (CAR (exps), env), new_env); + new_env = scm_cons (eval (CAR (exps), *inout_env), new_env); if (SCM_UNLIKELY (nreq != 0)) scm_wrong_num_args (proc); + *out_body = BOOT_CLOSURE_BODY (proc); + *inout_env = new_env; } else if (BOOT_CLOSURE_IS_REST (proc)) { if (SCM_UNLIKELY (argc < nreq)) scm_wrong_num_args (proc); for (; nreq; nreq--, exps = CDR (exps)) - new_env = scm_cons (eval (CAR (exps), env), new_env); + new_env = scm_cons (eval (CAR (exps), *inout_env), new_env); { SCM rest = SCM_EOL; for (; scm_is_pair (exps); exps = CDR (exps)) - rest = scm_cons (eval (CAR (exps), env), rest); + rest = scm_cons (eval (CAR (exps), *inout_env), rest); new_env = scm_cons (scm_reverse (rest), new_env); } + *out_body = BOOT_CLOSURE_BODY (proc); + *inout_env = new_env; } else { SCM args = SCM_EOL; for (; scm_is_pair (exps); exps = CDR (exps)) - args = scm_cons (eval (CAR (exps), env), args); - scm_reverse_x (args, SCM_UNDEFINED); - new_env = prepare_boot_closure_env_for_apply (proc, args); + args = scm_cons (eval (CAR (exps), *inout_env), args); + args = scm_reverse_x (args, SCM_UNDEFINED); + prepare_boot_closure_env_for_apply (proc, args, out_body, inout_env); } - return new_env; } static SCM boot_closure_apply (SCM closure, SCM args) { - return eval (BOOT_CLOSURE_BODY (closure), - prepare_boot_closure_env_for_apply (closure, args)); + SCM body, env; + prepare_boot_closure_env_for_apply (closure, args, &body, &env); + return eval (body, env); } static int @@ -1098,6 +1115,7 @@ boot_closure_print (SCM closure, SCM port, scm_print_state *pstate) scm_from_locale_symbol ("_")); if (!BOOT_CLOSURE_IS_FIXED (closure) && BOOT_CLOSURE_HAS_REST_ARGS (closure)) args = scm_cons_star (scm_from_locale_symbol ("_"), args); + /* FIXME: optionals and rests */ scm_display (args, port); scm_putc ('>', port); return 1; |