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/memoize.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/memoize.c')
-rw-r--r-- | libguile/memoize.c | 105 |
1 files changed, 96 insertions, 9 deletions
diff --git a/libguile/memoize.c b/libguile/memoize.c index 1b54a4b98..544de7cef 100644 --- a/libguile/memoize.c +++ b/libguile/memoize.c @@ -273,6 +273,8 @@ static SCM scm_m_eval_when (SCM xorig, SCM env); static SCM scm_m_if (SCM xorig, SCM env); static SCM scm_m_lambda (SCM xorig, SCM env); static SCM scm_m_lambda_star (SCM xorig, SCM env); +static SCM scm_m_case_lambda (SCM xorig, SCM env); +static SCM scm_m_case_lambda_star (SCM xorig, SCM env); static SCM scm_m_let (SCM xorig, SCM env); static SCM scm_m_letrec (SCM xorig, SCM env); static SCM scm_m_letstar (SCM xorig, SCM env); @@ -431,6 +433,8 @@ SCM_SYNTAX (s_letrec, "letrec", scm_m_letrec); SCM_SYNTAX (s_letstar, "let*", scm_m_letstar); SCM_SYNTAX (s_or, "or", scm_m_or); SCM_SYNTAX (s_lambda_star, "lambda*", scm_m_lambda_star); +SCM_SYNTAX (s_case_lambda, "case-lambda", scm_m_case_lambda); +SCM_SYNTAX (s_case_lambda_star, "case-lambda*", scm_m_case_lambda_star); SCM_GLOBAL_SYMBOL (scm_sym_apply, "apply"); SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>"); @@ -457,6 +461,8 @@ SCM_GLOBAL_SYMBOL (scm_sym_at_prompt, "@prompt"); SCM_GLOBAL_SYMBOL (scm_sym_quote, "quote"); SCM_GLOBAL_SYMBOL (scm_sym_set_x, "set!"); SCM_SYMBOL (sym_lambda_star, "lambda*"); +SCM_SYMBOL (sym_case_lambda, "case-lambda"); +SCM_SYMBOL (sym_case_lambda_star, "case-lambda*"); SCM_SYMBOL (sym_eval, "eval"); SCM_SYMBOL (sym_load, "load"); @@ -903,6 +909,83 @@ scm_m_lambda_star (SCM expr, SCM env) SCM_BOOL_F)); } +static SCM +patch_case_lambda (SCM a, SCM b) +{ + SCM mx, body, rest, kw_indices, inits; + int nreq, nopt; + + mx = SCM_SMOB_OBJECT_1 (a); + body = CAR (mx); + mx = CDR (mx); + + if (scm_is_null (CDR (mx))) + { + nreq = scm_to_int16 (CAR (mx)); + rest = SCM_BOOL_F; + nopt = 0; + kw_indices = SCM_BOOL_F; + inits = SCM_EOL; + } + else if (scm_is_null (CDDR (mx))) + { + nreq = scm_to_int16 (CAR (mx)); + rest = CADR (mx); + nopt = 0; + kw_indices = SCM_BOOL_F; + inits = SCM_EOL; + } + else + { + nreq = scm_to_int16 (CAR (mx)); + rest = CADR (mx); + nopt = scm_to_int16 (CADDR (mx)); + kw_indices = CADDDR (mx); + inits = CADR (CDDDR (mx)); + } + + return MAKMEMO_LAMBDA + (body, FULL_ARITY (nreq, rest, nopt, kw_indices, inits, b)); +} + +static SCM +scm_m_case_lambda (SCM expr, SCM env) +{ + SCM ret, clauses; + + const long length = scm_ilength (expr); + ASSERT_SYNTAX (length >= 1, s_bad_expression, expr); + ASSERT_SYNTAX (length >= 2, s_missing_expression, expr); + + clauses = scm_reverse (CDR (expr)); + ret = SCM_BOOL_F; + + for (; scm_is_pair (clauses); clauses = CDR (clauses)) + ret = patch_case_lambda + (scm_m_lambda (scm_cons (scm_sym_lambda, CAR (clauses)), env), ret); + + return ret; +} + +static SCM +scm_m_case_lambda_star (SCM expr, SCM env) +{ + SCM ret, clauses; + + const long length = scm_ilength (expr); + ASSERT_SYNTAX (length >= 1, s_bad_expression, expr); + ASSERT_SYNTAX (length >= 2, s_missing_expression, expr); + + clauses = scm_reverse (CDR (expr)); + ret = SCM_BOOL_F; + + for (; scm_is_pair (clauses); clauses = CDR (clauses)) + ret = patch_case_lambda + (scm_m_lambda_star (scm_cons (sym_lambda_star, CAR (clauses)), env), ret); + + return ret; +} + /* Check if the format of the bindings is ((<symbol> <init-form>) ...). */ static void check_bindings (const SCM bindings, const SCM expr) @@ -1521,19 +1604,23 @@ unmemoize (const SCM expr) } else { - SCM body = CAR (args), spec = CDR (args), alt; + SCM body = CAR (args), spec = CDR (args), alt, tail; alt = CADDR (CDDDR (spec)); if (scm_is_true (alt)) - abort (); + tail = CDR (unmemoize (alt)); + else + tail = SCM_EOL; - return scm_list_3 (sym_lambda_star, - scm_list_5 (CAR (spec), - CADR (spec), - CADDR (spec), - CADDDR (spec), - unmemoize_exprs (CADR (CDDDR (spec)))), - unmemoize (body)); + return scm_cons + (sym_case_lambda_star, + scm_cons (scm_list_2 (scm_list_5 (CAR (spec), + CADR (spec), + CADDR (spec), + CADDDR (spec), + unmemoize_exprs (CADR (CDDDR (spec)))), + unmemoize (body)), + tail)); } case SCM_M_LET: return scm_list_3 (scm_sym_let, |