summaryrefslogtreecommitdiff
path: root/libguile/eval.c
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2010-05-13 17:15:10 +0200
committerAndy Wingo <wingo@pobox.com>2010-05-14 00:28:32 +0200
commitd8a071fc4e709ee83cd3c7fc935f7ec21375e624 (patch)
tree50cfb2eca1aa4d7b275c992862d9a677471a588c /libguile/eval.c
parent9658182d5f51368e2888cb461edfc2f35f91c6ac (diff)
downloadguile-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.c149
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;
}