summaryrefslogtreecommitdiff
path: root/libguile/eval.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/eval.c')
-rw-r--r--libguile/eval.c811
1 files changed, 500 insertions, 311 deletions
diff --git a/libguile/eval.c b/libguile/eval.c
index 65d9016d4..bb56db39a 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -89,8 +89,10 @@ char *alloca ();
+static SCM unmemoize_exprs (SCM expr, SCM env);
static SCM canonicalize_define (SCM expr);
static SCM *scm_lookupcar1 (SCM vloc, SCM genv, int check);
+static SCM unmemoize_builtin_macro (SCM expr, SCM env);
@@ -526,6 +528,69 @@ is_self_quoting_p (const SCM expr)
}
+SCM_SYMBOL (sym_three_question_marks, "???");
+
+static SCM
+unmemoize_expression (const SCM expr, const SCM env)
+{
+ if (SCM_ILOCP (expr))
+ {
+ SCM frame_idx;
+ unsigned long int frame_nr;
+ SCM symbol_idx;
+ unsigned long int symbol_nr;
+
+ for (frame_idx = env, frame_nr = SCM_IFRAME (expr);
+ frame_nr != 0;
+ frame_idx = SCM_CDR (frame_idx), --frame_nr)
+ ;
+ for (symbol_idx = SCM_CAAR (frame_idx), symbol_nr = SCM_IDIST (expr);
+ symbol_nr != 0;
+ symbol_idx = SCM_CDR (symbol_idx), --symbol_nr)
+ ;
+ return SCM_ICDRP (expr) ? symbol_idx : SCM_CAR (symbol_idx);
+ }
+ else if (SCM_VARIABLEP (expr))
+ {
+ const SCM sym = scm_module_reverse_lookup (scm_env_module (env), expr);
+ return !SCM_FALSEP (sym) ? sym : sym_three_question_marks;
+ }
+ else if (SCM_VECTORP (expr))
+ {
+ return scm_list_2 (scm_sym_quote, expr);
+ }
+ else if (!SCM_CONSP (expr))
+ {
+ return expr;
+ }
+ else if (SCM_ISYMP (SCM_CAR (expr)))
+ {
+ return unmemoize_builtin_macro (expr, env);
+ }
+ else
+ {
+ return unmemoize_exprs (expr, env);
+ }
+}
+
+
+static SCM
+unmemoize_exprs (const SCM exprs, const SCM env)
+{
+ SCM result = SCM_EOL;
+ SCM expr_idx;
+
+ for (expr_idx = exprs; !SCM_NULLP (expr_idx); expr_idx = SCM_CDR (expr_idx))
+ {
+ const SCM expr = SCM_CAR (expr_idx);
+ const SCM um_expr = unmemoize_expression (expr, env);
+ result = scm_cons (um_expr, result);
+ }
+
+ return scm_reverse_x (result, SCM_UNDEFINED);
+}
+
+
/* Rewrite the body (which is given as the list of expressions forming the
* body) into its internal form. The internal form of a body (<expr> ...) is
* just the body itself, but prefixed with an ISYM that denotes to what kind
@@ -814,6 +879,12 @@ scm_m_and (SCM expr, SCM env SCM_UNUSED)
}
}
+static SCM
+unmemoize_and (const SCM expr, const SCM env)
+{
+ return scm_cons (scm_sym_and, unmemoize_exprs (SCM_CDR (expr), env));
+}
+
SCM_SYNTAX (s_begin, "begin", scm_i_makbimacro, scm_m_begin);
SCM_GLOBAL_SYMBOL (scm_sym_begin, s_begin);
@@ -831,6 +902,12 @@ scm_m_begin (SCM expr, SCM env SCM_UNUSED)
return expr;
}
+static SCM
+unmemoize_begin (const SCM expr, const SCM env)
+{
+ return scm_cons (scm_sym_begin, unmemoize_exprs (SCM_CDR (expr), env));
+}
+
SCM_SYNTAX (s_case, "case", scm_i_makbimacro, scm_m_case);
SCM_GLOBAL_SYMBOL (scm_sym_case, s_case);
@@ -899,6 +976,34 @@ scm_m_case (SCM expr, SCM env)
return expr;
}
+static SCM
+unmemoize_case (const SCM expr, const SCM env)
+{
+ const SCM um_key_expr = unmemoize_expression (SCM_CADR (expr), env);
+ SCM um_clauses = SCM_EOL;
+ SCM clause_idx;
+
+ for (clause_idx = SCM_CDDR (expr);
+ !SCM_NULLP (clause_idx);
+ clause_idx = SCM_CDR (clause_idx))
+ {
+ const SCM clause = SCM_CAR (clause_idx);
+ const SCM labels = SCM_CAR (clause);
+ const SCM exprs = SCM_CDR (clause);
+
+ const SCM um_exprs = unmemoize_exprs (exprs, env);
+ const SCM um_labels = (SCM_EQ_P (labels, SCM_IM_ELSE))
+ ? scm_sym_else
+ : scm_i_finite_list_copy (labels);
+ const SCM um_clause = scm_cons (um_labels, um_exprs);
+
+ um_clauses = scm_cons (um_clause, um_clauses);
+ }
+ um_clauses = scm_reverse_x (um_clauses, SCM_UNDEFINED);
+
+ return scm_cons2 (scm_sym_case, um_key_expr, um_clauses);
+}
+
SCM_SYNTAX (s_cond, "cond", scm_i_makbimacro, scm_m_cond);
SCM_GLOBAL_SYMBOL (scm_sym_cond, s_cond);
@@ -951,6 +1056,47 @@ scm_m_cond (SCM expr, SCM env)
return expr;
}
+static SCM
+unmemoize_cond (const SCM expr, const SCM env)
+{
+ SCM um_clauses = SCM_EOL;
+ SCM clause_idx;
+
+ for (clause_idx = SCM_CDR (expr);
+ !SCM_NULLP (clause_idx);
+ clause_idx = SCM_CDR (clause_idx))
+ {
+ const SCM clause = SCM_CAR (clause_idx);
+ const SCM sequence = SCM_CDR (clause);
+ const SCM test = SCM_CAR (clause);
+ SCM um_test;
+ SCM um_sequence;
+ SCM um_clause;
+
+ if (SCM_EQ_P (test, SCM_IM_ELSE))
+ um_test = scm_sym_else;
+ else
+ um_test = unmemoize_expression (test, env);
+
+ if (!SCM_NULLP (sequence) && SCM_EQ_P (SCM_CAR (sequence), SCM_IM_ARROW))
+ {
+ const SCM target = SCM_CADR (sequence);
+ const SCM um_target = unmemoize_expression (target, env);
+ um_sequence = scm_list_2 (scm_sym_arrow, um_target);
+ }
+ else
+ {
+ um_sequence = unmemoize_exprs (sequence, env);
+ }
+
+ um_clause = scm_cons (um_test, um_sequence);
+ um_clauses = scm_cons (um_clause, um_clauses);
+ }
+ um_clauses = scm_reverse_x (um_clauses, SCM_UNDEFINED);
+
+ return scm_cons (scm_sym_cond, um_clauses);
+}
+
SCM_SYNTAX (s_define, "define", scm_i_makbimacro, scm_m_define);
SCM_GLOBAL_SYMBOL (scm_sym_define, s_define);
@@ -1077,6 +1223,13 @@ scm_m_delay (SCM expr, SCM env)
return new_expr;
}
+static SCM
+unmemoize_delay (const SCM expr, const SCM env)
+{
+ const SCM thunk_expr = SCM_CADDR (expr);
+ return scm_list_2 (scm_sym_delay, unmemoize_expression (thunk_expr, env));
+}
+
SCM_SYNTAX(s_do, "do", scm_i_makbimacro, scm_m_do);
SCM_GLOBAL_SYMBOL(scm_sym_do, s_do);
@@ -1156,6 +1309,43 @@ scm_m_do (SCM expr, SCM env SCM_UNUSED)
return expr;
}
+static SCM
+unmemoize_do (const SCM expr, const SCM env)
+{
+ const SCM cdr_expr = SCM_CDR (expr);
+ const SCM cddr_expr = SCM_CDR (cdr_expr);
+ const SCM rnames = SCM_CAR (cddr_expr);
+ const SCM extended_env = SCM_EXTEND_ENV (rnames, SCM_EOL, env);
+ const SCM cdddr_expr = SCM_CDR (cddr_expr);
+ const SCM exit_sequence = SCM_CAR (cdddr_expr);
+ const SCM um_exit_sequence = unmemoize_exprs (exit_sequence, extended_env);
+ const SCM cddddr_expr = SCM_CDR (cdddr_expr);
+ const SCM um_body = unmemoize_exprs (SCM_CAR (cddddr_expr), extended_env);
+
+ /* build transformed binding list */
+ SCM um_names = scm_reverse (rnames);
+ SCM um_inits = unmemoize_exprs (SCM_CAR (cdr_expr), env);
+ SCM um_steps = unmemoize_exprs (SCM_CDR (cddddr_expr), extended_env);
+ SCM um_bindings = SCM_EOL;
+ while (!SCM_NULLP (um_names))
+ {
+ const SCM name = SCM_CAR (um_names);
+ const SCM init = SCM_CAR (um_inits);
+ SCM step = SCM_CAR (um_steps);
+ step = SCM_EQ_P (step, name) ? SCM_EOL : scm_list_1 (step);
+
+ um_bindings = scm_cons (scm_cons2 (name, init, step), um_bindings);
+
+ um_names = SCM_CDR (um_names);
+ um_inits = SCM_CDR (um_inits);
+ um_steps = SCM_CDR (um_steps);
+ }
+ um_bindings = scm_reverse_x (um_bindings, SCM_UNDEFINED);
+
+ return scm_cons (scm_sym_do,
+ scm_cons2 (um_bindings, um_exit_sequence, um_body));
+}
+
SCM_SYNTAX (s_if, "if", scm_i_makbimacro, scm_m_if);
SCM_GLOBAL_SYMBOL (scm_sym_if, s_if);
@@ -1170,6 +1360,26 @@ scm_m_if (SCM expr, SCM env SCM_UNUSED)
return expr;
}
+static SCM
+unmemoize_if (const SCM expr, const SCM env)
+{
+ const SCM cdr_expr = SCM_CDR (expr);
+ const SCM um_condition = unmemoize_expression (SCM_CAR (cdr_expr), env);
+ const SCM cddr_expr = SCM_CDR (cdr_expr);
+ const SCM um_then = unmemoize_expression (SCM_CAR (cddr_expr), env);
+ const SCM cdddr_expr = SCM_CDR (cddr_expr);
+
+ if (SCM_NULLP (cdddr_expr))
+ {
+ return scm_list_3 (scm_sym_if, um_condition, um_then);
+ }
+ else
+ {
+ const SCM um_else = unmemoize_expression (SCM_CAR (cdddr_expr), env);
+ return scm_list_4 (scm_sym_if, um_condition, um_then, um_else);
+ }
+}
+
SCM_SYNTAX (s_lambda, "lambda", scm_i_makbimacro, scm_m_lambda);
SCM_GLOBAL_SYMBOL (scm_sym_lambda, s_lambda);
@@ -1252,6 +1462,19 @@ scm_m_lambda (SCM expr, SCM env SCM_UNUSED)
return expr;
}
+static SCM
+unmemoize_lambda (const SCM expr, const SCM env)
+{
+ const SCM formals = SCM_CADR (expr);
+ const SCM body = SCM_CDDR (expr);
+
+ const SCM new_env = SCM_EXTEND_ENV (formals, SCM_EOL, env);
+ const SCM um_formals = scm_i_finite_list_copy (formals);
+ const SCM um_body = unmemoize_exprs (body, new_env);
+
+ return scm_cons2 (scm_sym_lambda, um_formals, um_body);
+}
+
/* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
static void
@@ -1388,6 +1611,84 @@ scm_m_let (SCM expr, SCM env)
}
}
+static SCM
+build_binding_list (SCM rnames, SCM rinits)
+{
+ SCM bindings = SCM_EOL;
+ while (!SCM_NULLP (rnames))
+ {
+ const SCM binding = scm_list_2 (SCM_CAR (rnames), SCM_CAR (rinits));
+ bindings = scm_cons (binding, bindings);
+ rnames = SCM_CDR (rnames);
+ rinits = SCM_CDR (rinits);
+ }
+ return bindings;
+}
+
+static SCM
+unmemoize_let (const SCM expr, const SCM env)
+{
+ const SCM cdr_expr = SCM_CDR (expr);
+ const SCM um_rnames = SCM_CAR (cdr_expr);
+ const SCM extended_env = SCM_EXTEND_ENV (um_rnames, SCM_EOL, env);
+ const SCM cddr_expr = SCM_CDR (cdr_expr);
+ const SCM um_inits = unmemoize_exprs (SCM_CAR (cddr_expr), env);
+ const SCM um_rinits = scm_reverse_x (um_inits, SCM_UNDEFINED);
+ const SCM um_bindings = build_binding_list (um_rnames, um_rinits);
+ const SCM um_body = unmemoize_exprs (SCM_CDR (cddr_expr), extended_env);
+
+ return scm_cons2 (scm_sym_let, um_bindings, um_body);
+}
+
+
+SCM_SYNTAX(s_letrec, "letrec", scm_i_makbimacro, scm_m_letrec);
+SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
+
+SCM
+scm_m_letrec (SCM expr, SCM env)
+{
+ SCM bindings;
+
+ const SCM cdr_expr = SCM_CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
+
+ bindings = SCM_CAR (cdr_expr);
+ if (SCM_NULLP (bindings))
+ {
+ /* no bindings, let* is executed faster */
+ SCM body = m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr));
+ return scm_m_letstar (scm_cons2 (SCM_CAR (expr), SCM_EOL, body), env);
+ }
+ else
+ {
+ SCM rvariables;
+ SCM inits;
+ SCM new_body;
+
+ check_bindings (bindings, expr);
+ transform_bindings (bindings, expr, &rvariables, &inits);
+ new_body = m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr));
+ return scm_cons2 (SCM_IM_LETREC, rvariables, scm_cons (inits, new_body));
+ }
+}
+
+static SCM
+unmemoize_letrec (const SCM expr, const SCM env)
+{
+ const SCM cdr_expr = SCM_CDR (expr);
+ const SCM um_rnames = SCM_CAR (cdr_expr);
+ const SCM extended_env = SCM_EXTEND_ENV (um_rnames, SCM_EOL, env);
+ const SCM cddr_expr = SCM_CDR (cdr_expr);
+ const SCM um_inits = unmemoize_exprs (SCM_CAR (cddr_expr), extended_env);
+ const SCM um_rinits = scm_reverse_x (um_inits, SCM_UNDEFINED);
+ const SCM um_bindings = build_binding_list (um_rnames, um_rinits);
+ const SCM um_body = unmemoize_exprs (SCM_CDR (cddr_expr), extended_env);
+
+ return scm_cons2 (scm_sym_letrec, um_bindings, um_body);
+}
+
+
SCM_SYNTAX (s_letstar, "let*", scm_i_makbimacro, scm_m_letstar);
SCM_GLOBAL_SYMBOL (scm_sym_letstar, s_letstar);
@@ -1437,37 +1738,30 @@ scm_m_letstar (SCM expr, SCM env SCM_UNUSED)
return expr;
}
-
-SCM_SYNTAX(s_letrec, "letrec", scm_i_makbimacro, scm_m_letrec);
-SCM_GLOBAL_SYMBOL(scm_sym_letrec, s_letrec);
-
-SCM
-scm_m_letrec (SCM expr, SCM env)
+static SCM
+unmemoize_letstar (const SCM expr, const SCM env)
{
- SCM bindings;
-
const SCM cdr_expr = SCM_CDR (expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
- ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
+ const SCM body = SCM_CDR (cdr_expr);
+ SCM bindings = SCM_CAR (cdr_expr);
+ SCM um_bindings = SCM_EOL;
+ SCM extended_env = env;
+ SCM um_body;
- bindings = SCM_CAR (cdr_expr);
- if (SCM_NULLP (bindings))
+ while (!SCM_NULLP (bindings))
{
- /* no bindings, let* is executed faster */
- SCM body = m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr));
- return scm_m_letstar (scm_cons2 (SCM_CAR (expr), SCM_EOL, body), env);
+ const SCM variable = SCM_CAR (bindings);
+ const SCM init = SCM_CADR (bindings);
+ const SCM um_init = unmemoize_expression (init, extended_env);
+ um_bindings = scm_cons (scm_list_2 (variable, um_init), um_bindings);
+ extended_env = SCM_EXTEND_ENV (variable, SCM_BOOL_F, extended_env);
+ bindings = SCM_CDDR (bindings);
}
- else
- {
- SCM rvariables;
- SCM inits;
- SCM new_body;
+ um_bindings = scm_reverse_x (um_bindings, SCM_UNDEFINED);
- check_bindings (bindings, expr);
- transform_bindings (bindings, expr, &rvariables, &inits);
- new_body = m_body (SCM_IM_LETREC, SCM_CDR (cdr_expr));
- return scm_cons2 (SCM_IM_LETREC, rvariables, scm_cons (inits, new_body));
- }
+ um_body = unmemoize_exprs (body, extended_env);
+
+ return scm_cons2 (scm_sym_letstar, um_bindings, um_body);
}
@@ -1494,6 +1788,12 @@ scm_m_or (SCM expr, SCM env SCM_UNUSED)
}
}
+static SCM
+unmemoize_or (const SCM expr, const SCM env)
+{
+ return scm_cons (scm_sym_or, unmemoize_exprs (SCM_CDR (expr), env));
+}
+
SCM_SYNTAX (s_quasiquote, "quasiquote", scm_makacro, scm_m_quasiquote);
SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, s_quasiquote);
@@ -1625,6 +1925,12 @@ scm_m_set_x (SCM expr, SCM env SCM_UNUSED)
return expr;
}
+static SCM
+unmemoize_set_x (const SCM expr, const SCM env)
+{
+ return scm_cons (scm_sym_set_x, unmemoize_exprs (SCM_CDR (expr), env));
+}
+
/* Start of the memoizers for non-R5RS builtin macros. */
@@ -1644,6 +1950,12 @@ scm_m_apply (SCM expr, SCM env SCM_UNUSED)
return expr;
}
+static SCM
+unmemoize_apply (const SCM expr, const SCM env)
+{
+ return scm_list_2 (scm_sym_atapply, unmemoize_exprs (SCM_CDR (expr), env));
+}
+
SCM_SYNTAX (s_atbind, "@bind", scm_i_makbimacro, scm_m_atbind);
@@ -1714,6 +2026,12 @@ scm_m_cont (SCM expr, SCM env SCM_UNUSED)
return expr;
}
+static SCM
+unmemoize_atcall_cc (const SCM expr, const SCM env)
+{
+ return scm_list_2 (scm_sym_atcall_cc, unmemoize_exprs (SCM_CDR (expr), env));
+}
+
SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_i_makbimacro, scm_m_at_call_with_values);
SCM_GLOBAL_SYMBOL(scm_sym_at_call_with_values, s_at_call_with_values);
@@ -1729,6 +2047,13 @@ scm_m_at_call_with_values (SCM expr, SCM env SCM_UNUSED)
return expr;
}
+static SCM
+unmemoize_at_call_with_values (const SCM expr, const SCM env)
+{
+ return scm_list_2 (scm_sym_at_call_with_values,
+ unmemoize_exprs (SCM_CDR (expr), env));
+}
+
SCM_SYNTAX (s_future, "future", scm_i_makbimacro, scm_m_future);
SCM_GLOBAL_SYMBOL (scm_sym_future, s_future);
@@ -1746,6 +2071,13 @@ scm_m_future (SCM expr, SCM env)
return new_expr;
}
+static SCM
+unmemoize_future (const SCM expr, const SCM env)
+{
+ const SCM thunk_expr = SCM_CADDR (expr);
+ return scm_list_2 (scm_sym_future, unmemoize_expression (thunk_expr, env));
+}
+
SCM_SYNTAX (s_gset_x, "set!", scm_i_makbimacro, scm_m_generalized_set_x);
SCM_SYMBOL (scm_sym_setter, "setter");
@@ -1806,6 +2138,9 @@ scm_m_generalized_set_x (SCM expr, SCM env)
* soon as the module system allows us to more freely create bindings in
* arbitrary modules during the startup phase, the code from goops.c should be
* moved here. */
+
+SCM_SYMBOL (sym_atslot_ref, "@slot-ref");
+
SCM
scm_m_atslot_ref (SCM expr, SCM env SCM_UNUSED)
{
@@ -1822,11 +2157,23 @@ scm_m_atslot_ref (SCM expr, SCM env SCM_UNUSED)
return expr;
}
+static SCM
+unmemoize_atslot_ref (const SCM expr, const SCM env)
+{
+ const SCM instance = SCM_CADR (expr);
+ const SCM um_instance = unmemoize_expression (instance, env);
+ const SCM slot_nr = SCM_CDDR (expr);
+ return scm_list_3 (sym_atslot_ref, um_instance, slot_nr);
+}
+
/* @slot-set! is bound privately in the (oop goops) module from goops.c. As
* soon as the module system allows us to more freely create bindings in
* arbitrary modules during the startup phase, the code from goops.c should be
* moved here. */
+
+SCM_SYMBOL (sym_atslot_set_x, "@slot-set!");
+
SCM
scm_m_atslot_set_x (SCM expr, SCM env SCM_UNUSED)
{
@@ -1842,6 +2189,20 @@ scm_m_atslot_set_x (SCM expr, SCM env SCM_UNUSED)
return expr;
}
+static SCM
+unmemoize_atslot_set_x (const SCM expr, const SCM env)
+{
+ const SCM cdr_expr = SCM_CDR (expr);
+ const SCM instance = SCM_CAR (cdr_expr);
+ const SCM um_instance = unmemoize_expression (instance, env);
+ const SCM cddr_expr = SCM_CDR (cdr_expr);
+ const SCM slot_nr = SCM_CAR (cddr_expr);
+ const SCM cdddr_expr = SCM_CDR (cddr_expr);
+ const SCM value = SCM_CAR (cdddr_expr);
+ const SCM um_value = unmemoize_expression (value, env);
+ return scm_list_4 (sym_atslot_set_x, um_instance, slot_nr, um_value);
+}
+
#if SCM_ENABLE_ELISP
@@ -1925,6 +2286,107 @@ scm_m_atfop (SCM expr, SCM env SCM_UNUSED)
#endif /* SCM_ENABLE_ELISP */
+static SCM
+unmemoize_builtin_macro (const SCM expr, const SCM env)
+{
+ switch (ISYMNUM (SCM_CAR (expr)))
+ {
+ case (ISYMNUM (SCM_IM_AND)):
+ return unmemoize_and (expr, env);
+
+ case (ISYMNUM (SCM_IM_BEGIN)):
+ return unmemoize_begin (expr, env);
+
+ case (ISYMNUM (SCM_IM_CASE)):
+ return unmemoize_case (expr, env);
+
+ case (ISYMNUM (SCM_IM_COND)):
+ return unmemoize_cond (expr, env);
+
+ case (ISYMNUM (SCM_IM_DELAY)):
+ return unmemoize_delay (expr, env);
+
+ case (ISYMNUM (SCM_IM_DO)):
+ return unmemoize_do (expr, env);
+
+ case (ISYMNUM (SCM_IM_IF)):
+ return unmemoize_if (expr, env);
+
+ case (ISYMNUM (SCM_IM_LAMBDA)):
+ return unmemoize_lambda (expr, env);
+
+ case (ISYMNUM (SCM_IM_LET)):
+ return unmemoize_let (expr, env);
+
+ case (ISYMNUM (SCM_IM_LETREC)):
+ return unmemoize_letrec (expr, env);
+
+ case (ISYMNUM (SCM_IM_LETSTAR)):
+ return unmemoize_letstar (expr, env);
+
+ case (ISYMNUM (SCM_IM_OR)):
+ return unmemoize_or (expr, env);
+
+ case (ISYMNUM (SCM_IM_QUOTE)):
+ return unmemoize_quote (expr, env);
+
+ case (ISYMNUM (SCM_IM_SET_X)):
+ return unmemoize_set_x (expr, env);
+
+ case (ISYMNUM (SCM_IM_APPLY)):
+ return unmemoize_apply (expr, env);
+
+ case (ISYMNUM (SCM_IM_BIND)):
+ return unmemoize_exprs (expr, env); /* FIXME */
+
+ case (ISYMNUM (SCM_IM_CONT)):
+ return unmemoize_atcall_cc (expr, env);
+
+ case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
+ return unmemoize_at_call_with_values (expr, env);
+
+ case (ISYMNUM (SCM_IM_FUTURE)):
+ return unmemoize_future (expr, env);
+
+ case (ISYMNUM (SCM_IM_SLOT_REF)):
+ return unmemoize_atslot_ref (expr, env);
+
+ case (ISYMNUM (SCM_IM_SLOT_SET_X)):
+ return unmemoize_atslot_set_x (expr, env);
+
+ case (ISYMNUM (SCM_IM_NIL_COND)):
+ return unmemoize_exprs (expr, env); /* FIXME */
+
+ default:
+ return unmemoize_exprs (expr, env); /* FIXME */
+ }
+}
+
+
+/* scm_unmemocopy takes a memoized body together with its environment and
+ * rewrites it to its original form. Thus, it is the inversion of the rewrite
+ * rules above. The procedure is not optimized for speed. It's used in
+ * scm_unmemoize, scm_procedure_source, macro_print and scm_iprin1.
+ *
+ * Unmemoizing is not a reliable process. You cannot in general expect to get
+ * the original source back.
+ *
+ * However, GOOPS currently relies on this for method compilation. This ought
+ * to change. */
+
+SCM
+scm_unmemocopy (SCM forms, SCM env)
+{
+ const SCM source_properties = scm_whash_lookup (scm_source_whash, forms);
+ const SCM um_forms = unmemoize_exprs (forms, env);
+
+ if (!SCM_FALSEP (source_properties))
+ scm_whash_insert (scm_source_whash, um_forms, source_properties);
+
+ return um_forms;
+}
+
+
#if (SCM_ENABLE_DEPRECATED == 1)
/* Deprecated in guile 1.7.0 on 2003-11-09. */
@@ -1974,50 +2436,15 @@ scm_macroexp (SCM x, SCM env)
#endif
-/*****************************************************************************/
-/*****************************************************************************/
-/* The definitions for unmemoization start here. */
-/*****************************************************************************/
-/*****************************************************************************/
-
-#define SCM_BIT7(x) (127 & SCM_UNPACK (x))
-
-SCM_SYMBOL (sym_three_question_marks, "???");
-
-/* scm_unmemocopy takes a memoized expression together with its
- * environment and rewrites it to its original form. Thus, it is the
- * inversion of the rewrite rules above. The procedure is not
- * optimized for speed. It's used in scm_iprin1 when printing the
- * code of a closure, in scm_procedure_source, in display_frame when
- * generating the source for a stackframe in a backtrace, and in
- * display_expression.
- *
- * Unmemoizing is not a reliable process. You cannot in general
- * expect to get the original source back.
- *
- * However, GOOPS currently relies on this for method compilation.
- * This ought to change.
- */
+#if (SCM_ENABLE_DEPRECATED == 1)
-static SCM
-build_binding_list (SCM rnames, SCM rinits)
+SCM
+scm_unmemocar (SCM form, SCM env)
{
- SCM bindings = SCM_EOL;
- while (!SCM_NULLP (rnames))
- {
- SCM binding = scm_list_2 (SCM_CAR (rnames), SCM_CAR (rinits));
- bindings = scm_cons (binding, bindings);
- rnames = SCM_CDR (rnames);
- rinits = SCM_CDR (rinits);
- }
- return bindings;
-}
-
+ scm_c_issue_deprecation_warning
+ ("`scm_unmemocar' is deprecated.");
-static SCM
-unmemocar (SCM form, SCM env)
-{
if (!SCM_CONSP (form))
return form;
else
@@ -2046,241 +2473,6 @@ unmemocar (SCM form, SCM env)
}
}
-
-SCM
-scm_unmemocopy (SCM x, SCM env)
-{
- SCM ls, z;
- SCM p;
-
- if (SCM_VECTORP (x))
- {
- return scm_list_2 (scm_sym_quote, x);
- }
- else if (!SCM_CONSP (x))
- return x;
-
- p = scm_whash_lookup (scm_source_whash, x);
- if (SCM_ISYMP (SCM_CAR (x)))
- {
- switch (ISYMNUM (SCM_CAR (x)))
- {
- case (ISYMNUM (SCM_IM_AND)):
- ls = z = scm_cons (scm_sym_and, SCM_UNSPECIFIED);
- break;
- case (ISYMNUM (SCM_IM_BEGIN)):
- ls = z = scm_cons (scm_sym_begin, SCM_UNSPECIFIED);
- break;
- case (ISYMNUM (SCM_IM_CASE)):
- ls = z = scm_cons (scm_sym_case, SCM_UNSPECIFIED);
- break;
- case (ISYMNUM (SCM_IM_COND)):
- ls = z = scm_cons (scm_sym_cond, SCM_UNSPECIFIED);
- break;
- case (ISYMNUM (SCM_IM_DO)):
- {
- /* format: (#@do (i1 ... ik) (nk ... n1) (test) (body) s1 ... sk),
- * where ix is an initializer for a local variable, nx is the name
- * of the local variable, test is the test clause of the do loop,
- * body is the body of the do loop and sx are the step clauses for
- * the local variables. */
- SCM names, inits, test, memoized_body, steps, bindings;
-
- x = SCM_CDR (x);
- inits = scm_reverse (scm_unmemocopy (SCM_CAR (x), env));
- x = SCM_CDR (x);
- names = SCM_CAR (x);
- env = SCM_EXTEND_ENV (names, SCM_EOL, env);
- x = SCM_CDR (x);
- test = scm_unmemocopy (SCM_CAR (x), env);
- x = SCM_CDR (x);
- memoized_body = SCM_CAR (x);
- x = SCM_CDR (x);
- steps = scm_reverse (scm_unmemocopy (x, env));
-
- /* build transformed binding list */
- bindings = SCM_EOL;
- while (!SCM_NULLP (names))
- {
- SCM name = SCM_CAR (names);
- SCM init = SCM_CAR (inits);
- SCM step = SCM_CAR (steps);
- step = SCM_EQ_P (step, name) ? SCM_EOL : scm_list_1 (step);
-
- bindings = scm_cons (scm_cons2 (name, init, step), bindings);
-
- names = SCM_CDR (names);
- inits = SCM_CDR (inits);
- steps = SCM_CDR (steps);
- }
- z = scm_cons (test, SCM_UNSPECIFIED);
- ls = scm_cons2 (scm_sym_do, bindings, z);
-
- x = scm_cons (SCM_BOOL_F, memoized_body);
- break;
- }
- case (ISYMNUM (SCM_IM_IF)):
- ls = z = scm_cons (scm_sym_if, SCM_UNSPECIFIED);
- break;
- case (ISYMNUM (SCM_IM_LET)):
- {
- /* format: (#@let (nk nk-1 ...) (i1 ... ik) b1 ...),
- * where nx is the name of a local variable, ix is an initializer
- * for the local variable and by are the body clauses. */
- SCM rnames, rinits, bindings;
-
- x = SCM_CDR (x);
- rnames = SCM_CAR (x);
- x = SCM_CDR (x);
- rinits = scm_reverse (scm_unmemocopy (SCM_CAR (x), env));
- env = SCM_EXTEND_ENV (rnames, SCM_EOL, env);
-
- bindings = build_binding_list (rnames, rinits);
- z = scm_cons (bindings, SCM_UNSPECIFIED);
- ls = scm_cons (scm_sym_let, z);
- break;
- }
- case (ISYMNUM (SCM_IM_LETREC)):
- {
- /* format: (#@letrec (vn ... v2 v1) (i1 i2 ... in) b1 ...),
- * where vx is the name of a local variable, ix is an initializer
- * for the local variable and by are the body clauses. */
- SCM rnames, rinits, bindings;
-
- x = SCM_CDR (x);
- rnames = SCM_CAR (x);
- env = SCM_EXTEND_ENV (rnames, SCM_EOL, env);
- x = SCM_CDR (x);
- rinits = scm_reverse (scm_unmemocopy (SCM_CAR (x), env));
-
- bindings = build_binding_list (rnames, rinits);
- z = scm_cons (bindings, SCM_UNSPECIFIED);
- ls = scm_cons (scm_sym_letrec, z);
- break;
- }
- case (ISYMNUM (SCM_IM_LETSTAR)):
- {
- SCM b, y;
- x = SCM_CDR (x);
- b = SCM_CAR (x);
- y = SCM_EOL;
- if (SCM_NULLP (b))
- {
- env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, env);
- }
- else
- {
- SCM copy = scm_unmemocopy (SCM_CADR (b), env);
- SCM initializer = unmemocar (scm_list_1 (copy), env);
- y = z = scm_acons (SCM_CAR (b), initializer, SCM_UNSPECIFIED);
- env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
- b = SCM_CDDR (b);
- if (SCM_NULLP (b))
- {
- SCM_SETCDR (y, SCM_EOL);
- z = scm_cons (y, SCM_UNSPECIFIED);
- ls = scm_cons (scm_sym_let, z);
- break;
- }
- do
- {
- copy = scm_unmemocopy (SCM_CADR (b), env);
- initializer = unmemocar (scm_list_1 (copy), env);
- SCM_SETCDR (z, scm_acons (SCM_CAR (b),
- initializer,
- SCM_UNSPECIFIED));
- z = SCM_CDR (z);
- env = SCM_EXTEND_ENV (SCM_CAR (b), SCM_BOOL_F, env);
- b = SCM_CDDR (b);
- }
- while (!SCM_NULLP (b));
- SCM_SETCDR (z, SCM_EOL);
- }
- z = scm_cons (y, SCM_UNSPECIFIED);
- ls = scm_cons (scm_sym_letstar, z);
- break;
- }
- case (ISYMNUM (SCM_IM_OR)):
- ls = z = scm_cons (scm_sym_or, SCM_UNSPECIFIED);
- break;
- case (ISYMNUM (SCM_IM_LAMBDA)):
- x = SCM_CDR (x);
- z = scm_cons (SCM_CAR (x), SCM_UNSPECIFIED);
- ls = scm_cons (scm_sym_lambda, z);
- env = SCM_EXTEND_ENV (SCM_CAR (x), SCM_EOL, env);
- break;
-
- case (ISYMNUM (SCM_IM_QUOTE)):
- return unmemoize_quote (x, env);
-
- case (ISYMNUM (SCM_IM_SET_X)):
- ls = z = scm_cons (scm_sym_set_x, SCM_UNSPECIFIED);
- break;
- case (ISYMNUM (SCM_IM_APPLY)):
- ls = z = scm_cons (scm_sym_atapply, SCM_UNSPECIFIED);
- break;
- case (ISYMNUM (SCM_IM_CONT)):
- ls = z = scm_cons (scm_sym_atcall_cc, SCM_UNSPECIFIED);
- break;
- case (ISYMNUM (SCM_IM_DELAY)):
- ls = z = scm_cons (scm_sym_delay, SCM_UNSPECIFIED);
- x = SCM_CDR (x);
- break;
- case (ISYMNUM (SCM_IM_FUTURE)):
- ls = z = scm_cons (scm_sym_future, SCM_UNSPECIFIED);
- x = SCM_CDR (x);
- break;
- case (ISYMNUM (SCM_IM_CALL_WITH_VALUES)):
- ls = z = scm_cons (scm_sym_at_call_with_values, SCM_UNSPECIFIED);
- break;
- case (ISYMNUM (SCM_IM_ELSE)):
- ls = z = scm_cons (scm_sym_else, SCM_UNSPECIFIED);
- break;
- default:
- ls = z = unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x), env),
- SCM_UNSPECIFIED),
- env);
- }
- }
- else
- {
- ls = z = unmemocar (scm_cons (scm_unmemocopy (SCM_CAR (x), env),
- SCM_UNSPECIFIED),
- env);
- }
-
- x = SCM_CDR (x);
- while (SCM_CONSP (x))
- {
- SCM form = SCM_CAR (x);
- if (!SCM_ISYMP (form))
- {
- SCM copy = scm_cons (scm_unmemocopy (form, env), SCM_UNSPECIFIED);
- SCM_SETCDR (z, unmemocar (copy, env));
- z = SCM_CDR (z);
- }
- else if (SCM_EQ_P (form, SCM_IM_ARROW))
- {
- SCM_SETCDR (z, scm_cons (scm_sym_arrow, SCM_UNSPECIFIED));
- z = SCM_CDR (z);
- }
- x = SCM_CDR (x);
- }
- SCM_SETCDR (z, x);
- if (!SCM_FALSEP (p))
- scm_whash_insert (scm_source_whash, ls, p);
- return ls;
-}
-
-
-#if (SCM_ENABLE_DEPRECATED == 1)
-
-SCM
-scm_unmemocar (SCM form, SCM env)
-{
- return unmemocar (form, env);
-}
-
#endif
/*****************************************************************************/
@@ -3024,7 +3216,7 @@ start:
scm_sym_enter_frame,
stackrep,
tail,
- scm_unmemocopy (x, env));
+ unmemoize_expression (x, env));
SCM_TRAPS_P = 1;
}
}
@@ -3318,9 +3510,7 @@ dispatch:
x = SCM_CDR (x);
{
SCM bindings = SCM_CAR (x);
- if (SCM_NULLP (bindings))
- env = SCM_EXTEND_ENV (SCM_EOL, SCM_EOL, env);
- else
+ if (!SCM_NULLP (bindings))
{
do
{
@@ -3844,7 +4034,7 @@ dispatch:
{
const SCM formals = SCM_CLOSURE_FORMALS (proc);
if (SCM_CONSP (formals))
- goto umwrongnumargs;
+ goto wrongnumargs;
x = SCM_CLOSURE_BODY (proc);
env = SCM_EXTEND_ENV (formals, SCM_EOL, SCM_ENV (proc));
goto nontoplevel_begin;
@@ -3877,8 +4067,7 @@ dispatch:
case scm_tc7_cxr:
case scm_tc7_subr_3:
case scm_tc7_lsubr_2:
- umwrongnumargs:
- unmemocar (x, env);
+ wrongnumargs:
scm_wrong_num_args (proc);
default:
badfun:
@@ -3978,7 +4167,7 @@ dispatch:
const SCM formals = SCM_CLOSURE_FORMALS (proc);
if (SCM_NULLP (formals)
|| (SCM_CONSP (formals) && SCM_CONSP (SCM_CDR (formals))))
- goto umwrongnumargs;
+ goto wrongnumargs;
x = SCM_CLOSURE_BODY (proc);
#ifdef DEVAL
env = SCM_EXTEND_ENV (formals,
@@ -4135,7 +4324,7 @@ dispatch:
&& (SCM_NULLP (SCM_CDR (formals))
|| (SCM_CONSP (SCM_CDR (formals))
&& SCM_CONSP (SCM_CDDR (formals))))))
- goto umwrongnumargs;
+ goto wrongnumargs;
#ifdef DEVAL
env = SCM_EXTEND_ENV (formals,
debug.info->a.args,
@@ -4218,7 +4407,7 @@ dispatch:
&& (SCM_NULLP (SCM_CDR (formals))
|| (SCM_CONSP (SCM_CDR (formals))
&& scm_badargsp (SCM_CDDR (formals), x)))))
- goto umwrongnumargs;
+ goto wrongnumargs;
SCM_SET_ARGSREADY (debug);
env = SCM_EXTEND_ENV (formals,
debug.info->a.args,
@@ -4280,7 +4469,7 @@ dispatch:
&& (SCM_NULLP (SCM_CDR (formals))
|| (SCM_CONSP (SCM_CDR (formals))
&& scm_badargsp (SCM_CDDR (formals), x)))))
- goto umwrongnumargs;
+ goto wrongnumargs;
env = SCM_EXTEND_ENV (formals,
scm_cons2 (arg1,
arg2,