summaryrefslogtreecommitdiff
path: root/libguile/memoize.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/memoize.c')
-rw-r--r--libguile/memoize.c171
1 files changed, 171 insertions, 0 deletions
diff --git a/libguile/memoize.c b/libguile/memoize.c
index 2cfb0cb00..1b54a4b98 100644
--- a/libguile/memoize.c
+++ b/libguile/memoize.c
@@ -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)