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 | |
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.
-rw-r--r-- | libguile/eval.c | 66 | ||||
-rw-r--r-- | libguile/memoize.c | 105 | ||||
-rw-r--r-- | module/ice-9/eval.scm | 32 |
3 files changed, 158 insertions, 45 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; 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, diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm index d4d4eb86d..e6e5f1713 100644 --- a/module/ice-9/eval.scm +++ b/module/ice-9/eval.scm @@ -218,20 +218,26 @@ ;; A unique marker for unbound keywords. (define unbound-arg (list 'unbound-arg)) - ;; Procedures with rest, optional, or keyword arguments. + ;; Procedures with rest, optional, or keyword arguments, potentially with + ;; multiple arities, as with case-lambda. (define (make-general-closure env body nreq rest? nopt kw inits alt) - (lambda args + (define alt-proc + (and alt + (apply make-general-closure env (memoized-expression-data alt)))) + (lambda %args (let lp ((env env) - (nreq nreq) - (args args)) - (if (> nreq 0) + (nreq* nreq) + (args %args)) + (if (> nreq* 0) ;; First, bind required arguments. (if (null? args) - (scm-error 'wrong-number-of-args - "eval" "Wrong number of arguments" - '() #f) + (if alt + (apply alt-proc %args) + (scm-error 'wrong-number-of-args + "eval" "Wrong number of arguments" + '() #f)) (lp (cons (car args) env) - (1- nreq) + (1- nreq*) (cdr args))) ;; Move on to optional arguments. (if (not kw) @@ -245,9 +251,11 @@ (eval body (cons args env)) (if (null? args) (eval body env) - (scm-error 'wrong-number-of-args - "eval" "Wrong number of arguments" - '() #f))) + (if alt + (apply alt-proc %args) + (scm-error 'wrong-number-of-args + "eval" "Wrong number of arguments" + '() #f)))) (if (null? args) (lp (cons (eval (car inits) env) env) (1- nopt) args (cdr inits)) |