mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 09:10:22 +02:00
Code Activity

primitive support for lambda*

Browse source 
* 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.
This commit is contained in:
Andy Wingo 2010-05-13 17:15:10 +02:00
parent 9658182d5f
commit d8a071fc4e
4 changed files with 472 additions and 31 deletions
Download patch file Download diff file Expand all files Collapse all files

149
libguile/eval.c
View file

@ -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;
}

171
libguile/memoize.c
View file

@ -272,6 +272,7 @@ static SCM scm_m_with_fluids (SCM xorig, SCM env);
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_let (SCM xorig, SCM env);
static SCM scm_m_letrec (SCM xorig, SCM env);
static SCM scm_m_letstar (SCM xorig, SCM env);
@ -429,6 +430,7 @@ SCM_SYNTAX (s_cond, "cond", scm_m_cond);
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_GLOBAL_SYMBOL (scm_sym_apply, "apply");
SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
@ -454,6 +456,7 @@ SCM_GLOBAL_SYMBOL (scm_sym_or, "or");
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_eval, "eval");
SCM_SYMBOL (sym_load, "load");
@ -461,6 +464,11 @@ SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote");
SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
SCM_KEYWORD (kw_allow_other_keys, "allow-other-keys");
SCM_KEYWORD (kw_optional, "optional");
SCM_KEYWORD (kw_key, "key");
SCM_KEYWORD (kw_rest, "rest");
static SCM
scm_m_at (SCM expr, SCM env SCM_UNUSED)
@ -732,6 +740,169 @@ scm_m_lambda (SCM expr, SCM env SCM_UNUSED)
return MAKMEMO_LAMBDA (body, FIXED_ARITY (nreq));
}
static SCM
scm_m_lambda_star (SCM expr, SCM env)
{
SCM req, opt, kw, allow_other_keys, rest, formals, body;
SCM inits, kw_indices;
int nreq, nopt;
const long length = scm_ilength (expr);
ASSERT_SYNTAX (length >= 1, s_bad_expression, expr);
ASSERT_SYNTAX (length >= 3, s_missing_expression, expr);
formals = CADR (expr);
body = CDDR (expr);
nreq = nopt = 0;
req = opt = kw = SCM_EOL;
rest = allow_other_keys = SCM_BOOL_F;
while (scm_is_pair (formals) && scm_is_symbol (CAR (formals)))
{
nreq++;
req = scm_cons (CAR (formals), req);
formals = scm_cdr (formals);
}
if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_optional))
{
formals = CDR (formals);
while (scm_is_pair (formals)
&& (scm_is_symbol (CAR (formals)) || scm_is_pair (CAR (formals))))
{
nopt++;
opt = scm_cons (CAR (formals), opt);
formals = scm_cdr (formals);
}
}
if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_key))
{
formals = CDR (formals);
while (scm_is_pair (formals)
&& (scm_is_symbol (CAR (formals)) || scm_is_pair (CAR (formals))))
{
kw = scm_cons (CAR (formals), kw);
formals = scm_cdr (formals);
}
}
if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_allow_other_keys))
{
formals = CDR (formals);
allow_other_keys = SCM_BOOL_T;
}
if (scm_is_pair (formals) && scm_is_eq (CAR (formals), kw_rest))
{
if (scm_ilength (formals) != 2)
syntax_error (s_bad_formals, CADR (expr), expr);
else
rest = CADR (formals);
}
else if (scm_is_symbol (formals))
rest = formals;
else if (!scm_is_null (formals))
syntax_error (s_bad_formals, CADR (expr), expr);
else
rest = SCM_BOOL_F;
/* Now, iterate through them a second time, building up an expansion-time
environment, checking, expanding and canonicalizing the opt/kw init forms,
and eventually memoizing the body as well. Note that the rest argument, if
any, is expanded before keyword args, thus necessitating the second
pass.
Also note that the specific environment during expansion of init
expressions here needs to coincide with the environment when psyntax
expands. A lot of effort for something that is only used in the bootstrap
memoizer, you say? Yes. Yes it is.
*/
inits = SCM_EOL;
/* nreq is already set, and req is already reversed: simply extend. */
env = memoize_env_extend (env, req);
/* Build up opt inits and env */
opt = scm_reverse_x (opt, SCM_EOL);
while (scm_is_pair (opt))
{
SCM x = CAR (opt);
if (scm_is_symbol (x))
inits = scm_cons (MAKMEMO_QUOTE (SCM_BOOL_F), inits);
else if (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)))
inits = scm_cons (memoize (CADR (x), env), inits);
else
syntax_error (s_bad_formals, CADR (expr), expr);
env = scm_cons (scm_is_symbol (x) ? x : CAR (x), env);
opt = CDR (opt);
}
/* Process rest before keyword args */
if (scm_is_true (rest))
env = scm_cons (rest, env);
/* Build up kw inits, env, and kw-indices alist */
if (scm_is_null (kw))
kw_indices = SCM_BOOL_F;
else
{
int idx = nreq + nopt + (scm_is_true (rest) ? 1 : 0);
kw_indices = SCM_EOL;
kw = scm_reverse_x (kw, SCM_EOL);
while (scm_is_pair (kw))
{
SCM x, sym, k, init;
x = CAR (kw);
if (scm_is_symbol (x))
{
sym = x;
init = SCM_BOOL_F;
k = scm_symbol_to_keyword (sym);
}
else if (scm_ilength (x) == 2 && scm_is_symbol (CAR (x)))
{
sym = CAR (x);
init = CADR (x);
k = scm_symbol_to_keyword (sym);
}
else if (scm_ilength (x) == 3 && scm_is_symbol (CAR (x))
&& scm_is_keyword (CADDR (x)))
{
sym = CAR (x);
init = CADR (x);
k = CADDR (x);
}
else
syntax_error (s_bad_formals, CADR (expr), expr);
kw_indices = scm_acons (k, SCM_I_MAKINUM (idx++), kw_indices);
inits = scm_cons (memoize (init, env), inits);
env = scm_cons (sym, env);
kw = CDR (kw);
}
kw_indices = scm_cons (allow_other_keys,
scm_reverse_x (kw_indices, SCM_UNDEFINED));
}
/* We should check for no duplicates, but given that psyntax does this
already, we can punt on it here... */
inits = scm_reverse_x (inits, SCM_UNDEFINED);
body = memoize_sequence (body, env);
if (scm_is_false (kw_indices) && scm_is_false (rest) && !nopt)
return MAKMEMO_LAMBDA (body, FIXED_ARITY (nreq));
if (scm_is_false (kw_indices) && !nopt)
return MAKMEMO_LAMBDA (body, REST_ARITY (nreq, SCM_BOOL_T));
else
return MAKMEMO_LAMBDA (body, FULL_ARITY (nreq, rest, nopt, kw_indices, inits,
SCM_BOOL_F));
}
/* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
static void
check_bindings (const SCM bindings, const SCM expr)