diff options
author | Andy Wingo <wingo@pobox.com> | 2010-05-13 17:15:10 +0200 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2010-05-14 00:28:32 +0200 |
commit | d8a071fc4e709ee83cd3c7fc935f7ec21375e624 (patch) | |
tree | 50cfb2eca1aa4d7b275c992862d9a677471a588c /libguile/eval.c | |
parent | 9658182d5f51368e2888cb461edfc2f35f91c6ac (diff) | |
download | guile-d8a071fc4e709ee83cd3c7fc935f7ec21375e624.tar.gz |
primitive support for lambda*
* libguile/memoize.c (scm_m_lambda_star): Define lambda* in the
pre-psyntax env, and make it memoize lambda* expressions.
* libguile/eval.c (BOOT_CLOSURE_PARSE_FULL): New helper.
(error_invalid_keyword, error_unrecognized_keyword): New helpers.
(prepare_boot_closure_env_for_apply): Flesh out application of boot
closures with "full" arity.
(prepare_boot_closure_env_for_eval): Punt to
prepare_boot_closure_env_for_eval for the full-arity case.
* module/ice-9/eval.scm (make-fixed-closure): Rename from `closure', and
just handle fixed arities, where there is no rest argument..
(make-general-closure): New helper, a procedure, that returns a
closure that can take rest, optional, and keyword arguments.
(eval): Adapt to call make-fixed-closure or make-general-closure as
appropriate.
* test-suite/tests/optargs.test ("lambda* inits"): Test the memoizer as
well.
Diffstat (limited to 'libguile/eval.c')
-rw-r--r-- | libguile/eval.c | 149 |
1 files changed, 145 insertions, 4 deletions
diff --git a/libguile/eval.c b/libguile/eval.c index fca599f61..ac004da55 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -114,8 +114,16 @@ static scm_t_bits scm_tc16_boot_closure; #define BOOT_CLOSURE_IS_REST(x) scm_is_null (CDDDR (BOOT_CLOSURE_CODE (x))) /* NB: One may only call the following accessors if the closure is not REST. */ #define BOOT_CLOSURE_IS_FULL(x) (1) -#define BOOT_CLOSURE_OPT(x) CAR (CDDDR (BOOT_CLOSURE_CODE (x))) -#define BOOT_CLOSURE_ALT(x) CADR (CDDDR (BOOT_CLOSURE_CODE (x))) +#define BOOT_CLOSURE_PARSE_FULL(x,body,nargs,rest,nopt,kw,inits,alt) \ + do { SCM mx = BOOT_CLOSURE_CODE (x); \ + body = CAR (mx); mx = CDR (mx); \ + nreq = SCM_I_INUM (CAR (mx)); mx = CDR (mx); \ + rest = CAR (mx); mx = CDR (mx); \ + nopt = SCM_I_INUM (CAR (mx)); mx = CDR (mx); \ + kw = CAR (mx); mx = CDR (mx); \ + 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); @@ -139,6 +147,21 @@ static void error_used_before_defined (void) "Variable used before given a value", SCM_EOL, SCM_BOOL_F); } +static void error_invalid_keyword (SCM proc) +{ + scm_error_scm (scm_from_locale_symbol ("keyword-argument-error"), proc, + scm_from_locale_string ("Invalid keyword"), SCM_EOL, + SCM_BOOL_F); +} + +static void error_unrecognized_keyword (SCM proc) +{ + scm_error_scm (scm_from_locale_symbol ("keyword-argument-error"), proc, + scm_from_locale_string ("Unrecognized keyword"), SCM_EOL, + SCM_BOOL_F); +} + + /* the environment: (VAL ... . MOD) If MOD is #f, it means the environment was captured before modules were @@ -900,7 +923,119 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args) env = scm_cons (args, env); } else - abort (); + { + int i, argc, nreq, nopt; + SCM body, rest, kw, inits, alt; + + 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 (); + else + scm_wrong_num_args (proc); + } + if (scm_is_false (kw) && argc > nreq + nopt && scm_is_false (rest)) + { + if (scm_is_true (alt)) + abort (); + else + scm_wrong_num_args (proc); + } + + for (i = 0; i < nreq; i++, args = CDR (args)) + env = scm_cons (CAR (args), env); + + if (scm_is_false (kw)) + { + /* Optional args (possibly), but no keyword args. */ + for (; i < argc && i < nreq + nopt; + i++, args = CDR (args)) + { + env = scm_cons (CAR (args), env); + inits = CDR (inits); + } + + for (; i < nreq + nopt; i++, inits = CDR (inits)) + env = scm_cons (eval (CAR (inits), env), env); + + if (scm_is_true (rest)) + env = scm_cons (args, env); + } + else + { + SCM aok; + + aok = CAR (kw); + kw = CDR (kw); + + /* Keyword args. As before, but stop at the first keyword. */ + for (; i < argc && i < nreq + nopt && !scm_is_keyword (CAR (args)); + i++, args = CDR (args), inits = CDR (inits)) + env = scm_cons (CAR (args), env); + + for (; i < nreq + nopt; i++, inits = CDR (inits)) + env = scm_cons (eval (CAR (inits), env), env); + + if (scm_is_true (rest)) + { + env = scm_cons (args, env); + i++; + } + + /* Now fill in env with unbound values, limn the rest of the args for + keywords, and fill in unbound values with their inits. */ + { + int imax = i - 1; + int kw_start_idx = i; + SCM walk, k, v; + for (walk = kw; scm_is_pair (walk); walk = CDR (walk)) + if (SCM_I_INUM (CDAR (walk)) > imax) + imax = SCM_I_INUM (CDAR (walk)); + for (; i <= imax; i++) + env = scm_cons (SCM_UNDEFINED, env); + + if (scm_is_pair (args) && scm_is_pair (CDR (args))) + for (; scm_is_pair (args) && scm_is_pair (CDR (args)); + args = CDR (args)) + { + k = CAR (args); v = CADR (args); + if (!scm_is_keyword (k)) + { + if (scm_is_true (rest)) + continue; + else + break; + } + for (walk = kw; scm_is_pair (walk); walk = CDR (walk)) + if (scm_is_eq (k, CAAR (walk))) + { + /* Well... ok, list-set! isn't the nicest interface, but + hey. */ + int iset = imax - SCM_I_INUM (CDAR (walk)); + scm_list_set_x (env, SCM_I_MAKINUM (iset), v); + args = CDR (args); + break; + } + if (scm_is_null (walk) && scm_is_false (aok)) + error_unrecognized_keyword (proc); + } + if (scm_is_pair (args) && scm_is_false (rest)) + error_invalid_keyword (proc); + + /* Now fill in unbound values, evaluating init expressions in their + appropriate environment. */ + for (i = imax - kw_start_idx; scm_is_pair (inits); i--, inits = CDR (inits)) + { + SCM tail = scm_list_tail (env, SCM_I_MAKINUM (i)); + if (SCM_UNBNDP (CAR (tail))) + SCM_SETCAR (tail, eval (CAR (inits), CDR (tail))); + } + } + } + } return env; } @@ -935,7 +1070,13 @@ prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc, } } else - abort (); + { + 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); + } return new_env; } |