summaryrefslogtreecommitdiff
path: root/libguile/memoize.c
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-11-28 01:19:50 +0100
committerAndy Wingo <wingo@pobox.com>2009-12-01 21:00:26 +0100
commitb7742c6b7132544b9d6cd9cb32c09e2084ad9e52 (patch)
tree1e39ea9eda8cfd3a4aca661e341d9245ae0fa91a /libguile/memoize.c
parent83c76550024c4a96c06cb75d40ab0ba122a0a57c (diff)
downloadguile-b7742c6b7132544b9d6cd9cb32c09e2084ad9e52.tar.gz
new evaluator, y'all
* libguile/eval.c: So, ladies & gents, a new evaluator. It's similar to the old one, in that we memoize and then evaluate, but in this incarnation, memoization of an expression happens before evaluation, not lazily as the expression is evaluated. This makes the evaluation itself much cleaner, in addition to being threadsafe. In addition, since this C evaluator will in the future just serve to bootstrap the Scheme evaluator, we don't have to pay much concern for debugging conveniences. So the environment is just a list of values, and the memoizer pre-computes where it's going to find each individual value in the environment. Interface changes are commented below, with eval.h. (scm_evaluator_traps): No need to reset the debug mode after rnning te traps thing. But really, the whole traps system needs some love. * libguile/memoize.h: * libguile/memoize.c: New memoizer, which runs before evaluation, checking all syntax before evaluation begins. Significantly, no debugging information is left for lexical variables, which is not so great for interactive debugging; perhaps we should change this to have a var list in the future as per the classic interpreters. But it's quite fast, and the resulting code is quite good. Also note that it doesn't produce ilocs, memoized code is a smob whose type is in the first word of the smob itself. * libguile/eval.h (scm_sym_and, scm_sym_begin, scm_sym_case) (scm_sym_cond, scm_sym_define, scm_sym_do, scm_sym_if, scm_sym_lambda) (scm_sym_let, scm_sym_letstar, scm_sym_letrec, scm_sym_quote) (scm_sym_quasiquote, scm_sym_unquote, scm_sym_uq_splicing, scm_sym_at) (scm_sym_atat, scm_sym_atapply, scm_sym_atcall_cc) (scm_sym_at_call_with_values, scm_sym_delay, scm_sym_eval_when) (scm_sym_arrow, scm_sym_else, scm_sym_apply, scm_sym_set_x) (scm_sym_args): Remove public declaration of these symbols. (scm_ilookup, scm_lookupcar, scm_eval_car, scm_eval_body) (scm_eval_args, scm_i_eval_x, scm_i_eval): Remove public declaration of these functions. (scm_ceval, scm_deval, scm_ceval_ptr): Remove declarations of these deprecated functions. (scm_i_print_iloc, scm_i_print_isym, scm_i_unmemocopy_expr) (scm_i_unmemocopy_body): Remove declarations of these internal functions. (scm_primitive_eval_x, scm_eval_x): Redefine as macros for their less destructive siblings. * libguile/Makefile.am: Add memoize.[ch] to the build. * libguile/debug.h (scm_debug_mode_p, scm_check_entry_p) (scm_check_apply_p, scm_check_exit_p, scm_check_memoize_p) (scm_debug_eframe_size): Remove these vars that were tied to the old evaluator's execution model. (SCM_RESET_DEBUG_MODE): Remove, no more need for this. (SCM_MEMOIZEDP, SCM_MEMOIZED_EXP, SCM_MEMOIZED_ENV): Remove macros referring to old memoized code representation. (scm_local_eval, scm_procedure_environment, scm_memoized_environment) (scm_make_memoized, scm_memoized_p): Remove functions operating on old memoized code representation. (scm_memcons, scm_mem_to_proc, scm_proc_to_mem): Remove debug-only code for old evaluator. * libguile/debug.c: Remove code to correspond with debug.h removals. (scm_debug_options): No need to set the debug mode or frame limit here, as we don't have C stack limits any more. Perhaps this is a bug, but as long as we can compile eval.scm, we should be fine. * libguile/init.c (scm_i_init_guile): Init memoize.c. * libguile/modules.c (scm_top_level_env, scm_env_top_level) (scm_env_module, scm_system_module_env_p): Remove these functions. * libguile/print.c (iprin1): No more need to handle isyms. Adapt to new form of interpreted procedures. * libguile/procprop.c (scm_i_procedure_arity): Adapt to new form of interpreted procedures. * libguile/procs.c (scm_thunk_p): Adapt to new form of interpreted procedures. * libguile/procs.h (SCM_CLOSURE_FORMALS): Removed, this exists no more. (SCM_CLOSURE_NUM_REQUIRED_ARGS, SCM_CLOSURE_HAS_REST_ARGS): New accessors. * libguile/srcprop.c (scm_source_properties, scm_source_property) (scm_set_source_property_x): Remove special cases for memoized code. * libguile/stacks.c (read_frame): Remove a source-property case for interpreted code. (NEXT_FRAME): Remove a case that I don't fully understand, that seems to be designed to skip over apply frames. Will be obsolete in the futures. (read_frames): Default source value for interpreted frames to #f. (narrow_stack): Don't pay attention to the system_module thing. * libguile/tags.h: Remove isyms and ilocs. Whee! * libguile/validate.h (SCM_VALIDATE_MEMOIZED): Fix to use the new MEMOIZED_P formulation. * module/ice-9/psyntax-pp.scm (do, quasiquote, case): Adapt for these no longer being primitive macros. * module/ice-9/boot-9.scm: Whitespace change, but just a poke to force a rebuild due to and/or/cond/... not being primitives any more. * module/ice-9/deprecated.scm (unmemoize-expr): Deprecate, it's unmemoize-expression now. * test-suite/tests/eval.test ("define set procedure-name"): XFAIL a couple of tests here; I don't know what to do about them. I reckon the expander should ensure that defined values are named. * test-suite/tests/chars.test ("basic char handling"): Fix expected exception when trying to apply a char.
Diffstat (limited to 'libguile/memoize.c')
-rw-r--r--libguile/memoize.c1141
1 files changed, 1141 insertions, 0 deletions
diff --git a/libguile/memoize.c b/libguile/memoize.c
new file mode 100644
index 000000000..d37a72374
--- /dev/null
+++ b/libguile/memoize.c
@@ -0,0 +1,1141 @@
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009
+ * Free Software Foundation, Inc.
+ *
+ * This library is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU Lesser General Public License
+ * as published by the Free Software Foundation; either version 3 of
+ * the License, or (at your option) any later version.
+ *
+ * This library is distributed in the hope that it will be useful, but
+ * WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+ * Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public
+ * License along with this library; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
+ * 02110-1301 USA
+ */
+
+
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include <alloca.h>
+
+#include "libguile/__scm.h"
+
+#include <assert.h>
+#include "libguile/_scm.h"
+#include "libguile/continuations.h"
+#include "libguile/eq.h"
+#include "libguile/list.h"
+#include "libguile/macros.h"
+#include "libguile/memoize.h"
+#include "libguile/modules.h"
+#include "libguile/srcprop.h"
+#include "libguile/ports.h"
+#include "libguile/print.h"
+#include "libguile/strings.h"
+#include "libguile/throw.h"
+#include "libguile/validate.h"
+
+
+
+
+
+#if 0
+#define CAR(x) SCM_CAR(x)
+#define CDR(x) SCM_CDR(x)
+#define CAAR(x) SCM_CAAR(x)
+#define CADR(x) SCM_CADR(x)
+#define CDAR(x) SCM_CDAR(x)
+#define CDDR(x) SCM_CDDR(x)
+#define CADDR(x) SCM_CADDR(x)
+#define CDDDR(x) SCM_CDDDR(x)
+#define CADDDR(x) SCM_CDDDR(x)
+#else
+#define CAR(x) scm_car(x)
+#define CDR(x) scm_cdr(x)
+#define CAAR(x) scm_caar(x)
+#define CADR(x) scm_cadr(x)
+#define CDAR(x) scm_cdar(x)
+#define CDDR(x) scm_cddr(x)
+#define CADDR(x) scm_caddr(x)
+#define CDDDR(x) scm_cdddr(x)
+#define CADDDR(x) scm_cadddr(x)
+#endif
+
+
+static const char s_bad_expression[] = "Bad expression";
+static const char s_expression[] = "Missing or extra expression in";
+static const char s_missing_expression[] = "Missing expression in";
+static const char s_extra_expression[] = "Extra expression in";
+static const char s_empty_combination[] = "Illegal empty combination";
+static const char s_missing_body_expression[] = "Missing body expression in";
+static const char s_mixed_body_forms[] = "Mixed definitions and expressions in";
+static const char s_bad_define[] = "Bad define placement";
+static const char s_missing_clauses[] = "Missing clauses";
+static const char s_misplaced_else_clause[] = "Misplaced else clause";
+static const char s_bad_case_clause[] = "Bad case clause";
+static const char s_bad_case_labels[] = "Bad case labels";
+static const char s_duplicate_case_label[] = "Duplicate case label";
+static const char s_bad_cond_clause[] = "Bad cond clause";
+static const char s_missing_recipient[] = "Missing recipient in";
+static const char s_bad_variable[] = "Bad variable";
+static const char s_bad_bindings[] = "Bad bindings";
+static const char s_bad_binding[] = "Bad binding";
+static const char s_duplicate_binding[] = "Duplicate binding";
+static const char s_bad_exit_clause[] = "Bad exit clause";
+static const char s_bad_formals[] = "Bad formals";
+static const char s_bad_formal[] = "Bad formal";
+static const char s_duplicate_formal[] = "Duplicate formal";
+static const char s_splicing[] = "Non-list result for unquote-splicing";
+static const char s_bad_slot_number[] = "Bad slot number";
+
+
+/* Signal a syntax error. We distinguish between the form that caused the
+ * error and the enclosing expression. The error message will print out as
+ * shown in the following pattern. The file name and line number are only
+ * given when they can be determined from the erroneous form or from the
+ * enclosing expression.
+ *
+ * <filename>: In procedure memoization:
+ * <filename>: In file <name>, line <nr>: <error-message> in <expression>. */
+
+SCM_SYMBOL (syntax_error_key, "syntax-error");
+
+/* The prototype is needed to indicate that the function does not return. */
+static void
+syntax_error (const char* const, const SCM, const SCM) SCM_NORETURN;
+
+static void
+syntax_error (const char* const msg, const SCM form, const SCM expr)
+{
+ SCM msg_string = scm_from_locale_string (msg);
+ SCM filename = SCM_BOOL_F;
+ SCM linenr = SCM_BOOL_F;
+ const char *format;
+ SCM args;
+
+ if (scm_is_pair (form))
+ {
+ filename = scm_source_property (form, scm_sym_filename);
+ linenr = scm_source_property (form, scm_sym_line);
+ }
+
+ if (scm_is_false (filename) && scm_is_false (linenr) && scm_is_pair (expr))
+ {
+ filename = scm_source_property (expr, scm_sym_filename);
+ linenr = scm_source_property (expr, scm_sym_line);
+ }
+
+ if (!SCM_UNBNDP (expr))
+ {
+ if (scm_is_true (filename))
+ {
+ format = "In file ~S, line ~S: ~A ~S in expression ~S.";
+ args = scm_list_5 (filename, linenr, msg_string, form, expr);
+ }
+ else if (scm_is_true (linenr))
+ {
+ format = "In line ~S: ~A ~S in expression ~S.";
+ args = scm_list_4 (linenr, msg_string, form, expr);
+ }
+ else
+ {
+ format = "~A ~S in expression ~S.";
+ args = scm_list_3 (msg_string, form, expr);
+ }
+ }
+ else
+ {
+ if (scm_is_true (filename))
+ {
+ format = "In file ~S, line ~S: ~A ~S.";
+ args = scm_list_4 (filename, linenr, msg_string, form);
+ }
+ else if (scm_is_true (linenr))
+ {
+ format = "In line ~S: ~A ~S.";
+ args = scm_list_3 (linenr, msg_string, form);
+ }
+ else
+ {
+ format = "~A ~S.";
+ args = scm_list_2 (msg_string, form);
+ }
+ }
+
+ scm_error (syntax_error_key, "memoization", format, args, SCM_BOOL_F);
+}
+
+
+/* Shortcut macros to simplify syntax error handling. */
+#define ASSERT_SYNTAX(cond, message, form) \
+ { if (SCM_UNLIKELY (!(cond))) \
+ syntax_error (message, form, SCM_UNDEFINED); }
+#define ASSERT_SYNTAX_2(cond, message, form, expr) \
+ { if (SCM_UNLIKELY (!(cond))) \
+ syntax_error (message, form, expr); }
+
+
+
+
+/* {Evaluator memoized expressions}
+ */
+
+scm_t_bits scm_tc16_memoized;
+
+#define MAKMEMO(n, args) (scm_cell (scm_tc16_memoized | ((n) << 16), (scm_t_bits)(args)))
+
+#define MAKMEMO_BEGIN(exps) \
+ MAKMEMO (SCM_M_BEGIN, exps)
+#define MAKMEMO_IF(test, then, else_) \
+ MAKMEMO (SCM_M_IF, scm_cons (test, scm_cons (then, else_)))
+#define MAKMEMO_LAMBDA(nreq, rest, body) \
+ MAKMEMO (SCM_M_LAMBDA, scm_cons (SCM_I_MAKINUM (nreq), scm_cons (rest, body)))
+#define MAKMEMO_LET(inits, body) \
+ MAKMEMO (SCM_M_LET, scm_cons (inits, body))
+#define MAKMEMO_QUOTE(exp) \
+ MAKMEMO (SCM_M_QUOTE, exp)
+#define MAKMEMO_DEFINE(var, val) \
+ MAKMEMO (SCM_M_DEFINE, scm_cons (var, val))
+#define MAKMEMO_APPLY(exp) \
+ MAKMEMO (SCM_M_APPLY, exp)
+#define MAKMEMO_CONT(proc) \
+ MAKMEMO (SCM_M_CONT, proc)
+#define MAKMEMO_CALL_WITH_VALUES(prod, cons) \
+ MAKMEMO (SCM_M_CALL_WITH_VALUES, scm_cons (prod, cons))
+#define MAKMEMO_CALL(proc, args) \
+ MAKMEMO (SCM_M_CALL, scm_cons (proc, args))
+#define MAKMEMO_LEX_REF(n) \
+ MAKMEMO (SCM_M_LEXICAL_REF, SCM_I_MAKINUM (n))
+#define MAKMEMO_LEX_SET(n, val) \
+ MAKMEMO (SCM_M_LEXICAL_SET, scm_cons (SCM_I_MAKINUM (n), val))
+#define MAKMEMO_TOP_REF(var) \
+ MAKMEMO (SCM_M_TOPLEVEL_REF, var)
+#define MAKMEMO_TOP_SET(var, val) \
+ MAKMEMO (SCM_M_TOPLEVEL_SET, scm_cons (var, val))
+#define MAKMEMO_MOD_REF(mod, var, public) \
+ MAKMEMO (SCM_M_MODULE_REF, scm_cons (mod, scm_cons (var, public)))
+#define MAKMEMO_MOD_SET(val, mod, var, public) \
+ MAKMEMO (SCM_M_MODULE_SET, scm_cons (val, scm_cons (mod, scm_cons (var, public))))
+
+
+
+/* This table must agree with the list of M_ constants in memoize.h */
+static const char *const memoized_tags[] =
+{
+ "begin",
+ "if",
+ "lambda",
+ "let",
+ "quote",
+ "define",
+ "apply",
+ "call-with-current-continuation",
+ "call-with-values",
+ "call",
+ "lexical-ref",
+ "lexical-set!",
+ "toplevel-ref",
+ "toplevel-set!",
+ "module-ref",
+ "module-set",
+};
+
+static int
+scm_print_memoized (SCM memoized, SCM port, scm_print_state *pstate)
+{
+ scm_puts ("#<memoized ", port);
+ scm_write (scm_unmemoize_expression (memoized), port);
+ scm_puts (">", port);
+ return 1;
+}
+
+static SCM scm_m_at (SCM xorig, SCM env);
+static SCM scm_m_atat (SCM xorig, SCM env);
+static SCM scm_m_and (SCM xorig, SCM env);
+static SCM scm_m_apply (SCM xorig, SCM env);
+static SCM scm_m_begin (SCM xorig, SCM env);
+static SCM scm_m_cont (SCM xorig, SCM env);
+static SCM scm_m_at_call_with_values (SCM xorig, SCM env);
+static SCM scm_m_cond (SCM xorig, SCM env);
+static SCM scm_m_define (SCM x, 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_let (SCM xorig, SCM env);
+static SCM scm_m_letrec (SCM xorig, SCM env);
+static SCM scm_m_letstar (SCM xorig, SCM env);
+static SCM scm_m_or (SCM xorig, SCM env);
+static SCM scm_m_quote (SCM xorig, SCM env);
+static SCM scm_m_set_x (SCM xorig, SCM env);
+
+
+
+
+
+typedef SCM (*t_syntax_transformer) (SCM, SCM);
+
+static t_syntax_transformer
+memoize_env_ref_transformer (SCM env, SCM x)
+{
+ SCM var;
+ for (; scm_is_pair (env); env = CDR (env))
+ if (scm_is_eq (x, CAR (env)))
+ return NULL; /* lexical */
+
+ var = scm_module_variable (env, x);
+ if (scm_is_true (var) && scm_is_true (scm_variable_bound_p (var))
+ && SCM_MACROP (scm_variable_ref (var)))
+ {
+ SCM mac = scm_variable_ref (var);
+ if (SCM_IMP (SCM_MACRO_CODE (mac))
+ || SCM_TYP7 (SCM_MACRO_CODE (mac)) != scm_tc7_subr_2)
+ syntax_error ("bad macro", x, SCM_UNDEFINED);
+ else
+ return (t_syntax_transformer)SCM_SUBRF (SCM_MACRO_CODE (mac)); /* global macro */
+ }
+ else
+ return NULL; /* anything else */
+}
+
+static int
+memoize_env_var_is_free (SCM env, SCM x)
+{
+ for (; scm_is_pair (env); env = CDR (env))
+ if (scm_is_eq (x, CAR (env)))
+ return 0; /* bound */
+ return 1; /* free */
+}
+
+static int
+memoize_env_lexical_index (SCM env, SCM x)
+{
+ int i = 0;
+ for (; scm_is_pair (env); env = CDR (env), i++)
+ if (scm_is_eq (x, CAR (env)))
+ return i; /* bound */
+ return -1; /* free */
+}
+
+static SCM
+memoize_env_extend (SCM env, SCM vars)
+{
+ return scm_append (scm_list_2 (vars, env));
+}
+
+static SCM
+memoize (SCM exp, SCM env)
+{
+ if (scm_is_pair (exp))
+ {
+ SCM CAR;
+ t_syntax_transformer trans;
+
+ CAR = CAR (exp);
+ if (scm_is_symbol (CAR))
+ trans = memoize_env_ref_transformer (env, CAR);
+ else
+ trans = NULL;
+
+ if (trans)
+ return trans (exp, env);
+ else
+ {
+ SCM args = SCM_EOL;
+ for (; scm_is_pair (exp); exp = CDR (exp))
+ args = scm_cons (memoize (CAR (exp), env), args);
+ if (scm_is_null (exp))
+ return MAKMEMO (SCM_M_CALL, scm_reverse_x (args, SCM_UNDEFINED));
+ else
+ syntax_error ("expected a proper list", exp, SCM_UNDEFINED);
+ }
+ }
+ else if (scm_is_symbol (exp))
+ {
+ int i = memoize_env_lexical_index (env, exp);
+ if (i < 0)
+ return MAKMEMO_TOP_REF (exp);
+ else
+ return MAKMEMO_LEX_REF (i);
+ }
+ else
+ return MAKMEMO_QUOTE (exp);
+}
+
+static SCM
+memoize_exprs (SCM forms, const SCM env)
+{
+ SCM ret = SCM_EOL;
+
+ for (; !scm_is_null (forms); forms = CDR (forms))
+ ret = scm_cons (memoize (CAR (forms), env), ret);
+ return scm_reverse_x (ret, SCM_UNDEFINED);
+}
+
+static SCM
+memoize_sequence (const SCM forms, const SCM env)
+{
+ ASSERT_SYNTAX (scm_ilength (forms) >= 1, s_bad_expression,
+ scm_cons (scm_sym_begin, forms));
+ return MAKMEMO_BEGIN (memoize_exprs (forms, env));
+}
+
+
+
+/* Memoization. */
+
+/* bimacros (built-in macros) have isym codes.
+ mmacros don't exist at runtime, they just expand out to more primitive
+ forms. */
+SCM_SYNTAX (s_at, "@", scm_i_makbimacro, scm_m_at);
+SCM_SYNTAX (s_atat, "@@", scm_i_makbimacro, scm_m_atat);
+SCM_SYNTAX (s_and, "and", scm_makmmacro, scm_m_and);
+SCM_SYNTAX (s_begin, "begin", scm_i_makbimacro, scm_m_begin);
+SCM_SYNTAX (s_atcall_cc, "@call-with-current-continuation", scm_i_makbimacro, scm_m_cont);
+SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_i_makbimacro, scm_m_at_call_with_values);
+SCM_SYNTAX (s_cond, "cond", scm_makmmacro, scm_m_cond);
+SCM_SYNTAX (s_define, "define", scm_i_makbimacro, scm_m_define);
+SCM_SYNTAX (s_eval_when, "eval-when", scm_makmmacro, scm_m_eval_when);
+SCM_SYNTAX (s_if, "if", scm_i_makbimacro, scm_m_if);
+SCM_SYNTAX (s_lambda, "lambda", scm_i_makbimacro, scm_m_lambda);
+SCM_SYNTAX (s_let, "let", scm_i_makbimacro, scm_m_let);
+SCM_SYNTAX (s_letrec, "letrec", scm_makmmacro, scm_m_letrec);
+SCM_SYNTAX (s_letstar, "let*", scm_makmmacro, scm_m_letstar);
+SCM_SYNTAX (s_or, "or", scm_makmmacro, scm_m_or);
+SCM_SYNTAX (s_quote, "quote", scm_i_makbimacro, scm_m_quote);
+SCM_SYNTAX (s_set_x, "set!", scm_i_makbimacro, scm_m_set_x);
+SCM_SYNTAX (s_atapply, "@apply", scm_i_makbimacro, scm_m_apply);
+
+
+SCM_GLOBAL_SYMBOL (scm_sym_apply, "apply");
+SCM_GLOBAL_SYMBOL (scm_sym_arrow, "=>");
+SCM_GLOBAL_SYMBOL (scm_sym_at, "@");
+SCM_GLOBAL_SYMBOL (scm_sym_atat, "@@");
+SCM_GLOBAL_SYMBOL (scm_sym_at_call_with_values, "@call-with-values");
+SCM_GLOBAL_SYMBOL (scm_sym_atapply, "@apply");
+SCM_GLOBAL_SYMBOL (scm_sym_atcall_cc, "@call-with-current-continuation");
+SCM_GLOBAL_SYMBOL (scm_sym_begin, "begin");
+SCM_GLOBAL_SYMBOL (scm_sym_case, "case");
+SCM_GLOBAL_SYMBOL (scm_sym_cond, "cond");
+SCM_GLOBAL_SYMBOL (scm_sym_define, "define");
+SCM_GLOBAL_SYMBOL (scm_sym_else, "else");
+SCM_GLOBAL_SYMBOL (scm_sym_eval_when, "eval-when");
+SCM_GLOBAL_SYMBOL (scm_sym_if, "if");
+SCM_GLOBAL_SYMBOL (scm_sym_lambda, "lambda");
+SCM_GLOBAL_SYMBOL (scm_sym_let, "let");
+SCM_GLOBAL_SYMBOL (scm_sym_letrec, "letrec");
+SCM_GLOBAL_SYMBOL (scm_sym_letstar, "let*");
+SCM_GLOBAL_SYMBOL (scm_sym_or, "or");
+SCM_GLOBAL_SYMBOL (scm_sym_quote, "quote");
+SCM_GLOBAL_SYMBOL (scm_sym_set_x, "set!");
+SCM_SYMBOL (sym_eval, "eval");
+SCM_SYMBOL (sym_load, "load");
+
+SCM_GLOBAL_SYMBOL (scm_sym_unquote, "unquote");
+SCM_GLOBAL_SYMBOL (scm_sym_quasiquote, "quasiquote");
+SCM_GLOBAL_SYMBOL (scm_sym_uq_splicing, "unquote-splicing");
+
+
+static SCM
+scm_m_at (SCM expr, SCM env SCM_UNUSED)
+{
+ ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);
+
+ return MAKMEMO_MOD_REF (CADR (expr), CADDR (expr), SCM_BOOL_T);
+}
+
+static SCM
+scm_m_atat (SCM expr, SCM env SCM_UNUSED)
+{
+ ASSERT_SYNTAX (scm_ilength (expr) == 3, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_is_symbol (CADDR (expr)), s_bad_expression, expr);
+
+ return MAKMEMO_MOD_REF (CADR (expr), CADDR (expr), SCM_BOOL_F);
+}
+
+static SCM
+scm_m_and (SCM expr, SCM env)
+{
+ const SCM cdr_expr = CDR (expr);
+
+ if (scm_is_null (cdr_expr))
+ return MAKMEMO_QUOTE (SCM_BOOL_T);
+ ASSERT_SYNTAX (scm_is_pair (cdr_expr), s_bad_expression, expr);
+
+ if (scm_is_null (CDR (cdr_expr)))
+ return memoize (CAR (cdr_expr), env);
+ else
+ return MAKMEMO_IF (memoize (CAR (cdr_expr), env),
+ scm_m_and (cdr_expr, env),
+ MAKMEMO_QUOTE (SCM_BOOL_F));
+}
+
+static SCM
+scm_m_apply (SCM expr, SCM env)
+{
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_missing_expression, expr);
+
+ return MAKMEMO_APPLY (memoize_exprs (cdr_expr, env));
+}
+
+static SCM
+scm_m_begin (SCM expr, SCM env)
+{
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 1, s_bad_expression, expr);
+ return MAKMEMO_BEGIN (memoize_exprs (cdr_expr, env));
+}
+
+static SCM
+scm_m_cont (SCM expr, SCM env)
+{
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
+
+ return MAKMEMO_CONT (memoize (CADR (expr), env));
+}
+
+static SCM
+scm_m_at_call_with_values (SCM expr, SCM env)
+{
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
+
+ return MAKMEMO_CALL_WITH_VALUES (memoize (CADR (expr), env),
+ memoize (CADDR (expr), env));
+}
+
+static SCM
+scm_m_cond (SCM expr, SCM env)
+{
+ /* Check, whether 'else or '=> is a literal, i. e. not bound to a value. */
+ const int else_literal_p = memoize_env_var_is_free (env, scm_sym_else);
+ const int arrow_literal_p = memoize_env_var_is_free (env, scm_sym_arrow);
+
+ const SCM clauses = CDR (expr);
+ SCM clause_idx;
+ SCM ret, loc;
+
+ ASSERT_SYNTAX (scm_ilength (clauses) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (clauses) >= 1, s_missing_clauses, expr);
+
+ ret = scm_cons (SCM_UNDEFINED, MAKMEMO_QUOTE (SCM_UNSPECIFIED));
+ loc = ret;
+
+ for (clause_idx = clauses;
+ !scm_is_null (clause_idx);
+ clause_idx = CDR (clause_idx))
+ {
+ SCM test;
+
+ const SCM clause = CAR (clause_idx);
+ const long length = scm_ilength (clause);
+ ASSERT_SYNTAX_2 (length >= 1, s_bad_cond_clause, clause, expr);
+
+ test = CAR (clause);
+ if (scm_is_eq (test, scm_sym_else) && else_literal_p)
+ {
+ const int last_clause_p = scm_is_null (CDR (clause_idx));
+ ASSERT_SYNTAX_2 (length >= 2,
+ s_bad_cond_clause, clause, expr);
+ ASSERT_SYNTAX_2 (last_clause_p,
+ s_misplaced_else_clause, clause, expr);
+ SCM_SETCDR (loc,
+ memoize (scm_cons (scm_sym_begin, CDR (clause)), env));
+ }
+ else if (length >= 2
+ && scm_is_eq (CADR (clause), scm_sym_arrow)
+ && arrow_literal_p)
+ {
+ SCM tmp = scm_gensym (scm_from_locale_string ("cond "));
+ SCM i;
+ SCM new_env = scm_cons (tmp, env);
+ ASSERT_SYNTAX_2 (length > 2, s_missing_recipient, clause, expr);
+ ASSERT_SYNTAX_2 (length == 3, s_extra_expression, clause, expr);
+ i = MAKMEMO_IF (MAKMEMO_LEX_REF (0),
+ MAKMEMO_CALL (memoize (CADDR (clause),
+ scm_cons (tmp, new_env)),
+ scm_list_1 (MAKMEMO_LEX_REF (0))),
+ MAKMEMO_QUOTE (SCM_UNSPECIFIED));
+ SCM_SETCDR (loc,
+ MAKMEMO_LET (scm_list_1 (memoize (CAR (clause), env)),
+ i));
+ env = new_env;
+ loc = scm_last_pair (SCM_MEMOIZED_ARGS (i));
+ }
+ /* FIXME length == 1 case */
+ else
+ {
+ SCM i = MAKMEMO_IF (memoize (CAR (clause), env),
+ memoize (scm_cons (scm_sym_begin, CDR (clause)), env),
+ MAKMEMO_QUOTE (SCM_UNSPECIFIED));
+ SCM_SETCDR (loc, i);
+ loc = scm_last_pair (SCM_MEMOIZED_ARGS (i));
+ }
+ }
+
+ return CDR (ret);
+}
+
+/* According to Section 5.2.1 of R5RS we first have to make sure that the
+ variable is bound, and then perform the `(set! variable expression)'
+ operation. However, EXPRESSION _can_ be evaluated before VARIABLE is
+ bound. This means that EXPRESSION won't necessarily be able to assign
+ values to VARIABLE as in `(define foo (begin (set! foo 1) (+ foo 1)))'. */
+static SCM
+scm_m_define (SCM expr, SCM env)
+{
+ const SCM cdr_expr = CDR (expr);
+ SCM body;
+ SCM variable;
+
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 2, s_missing_expression, expr);
+ ASSERT_SYNTAX (!scm_is_pair (env), s_bad_define, expr);
+
+ body = CDR (cdr_expr);
+ variable = CAR (cdr_expr);
+
+ if (scm_is_pair (variable))
+ {
+ ASSERT_SYNTAX_2 (scm_is_symbol (CAR (variable)), s_bad_variable, variable, expr);
+ return MAKMEMO_DEFINE (CAR (variable),
+ memoize (scm_cons (scm_sym_lambda,
+ scm_cons (CDR (variable), body)),
+ env));
+ }
+ ASSERT_SYNTAX_2 (scm_is_symbol (variable), s_bad_variable, variable, expr);
+ ASSERT_SYNTAX (scm_ilength (body) == 1, s_expression, expr);
+ return MAKMEMO_DEFINE (variable, memoize (CAR (body), env));
+}
+
+static SCM
+scm_m_eval_when (SCM expr, SCM env)
+{
+ ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (CADR (expr)) > 0, s_bad_expression, expr);
+
+ if (scm_is_true (scm_memq (sym_eval, CADR (expr)))
+ || scm_is_true (scm_memq (sym_load, CADR (expr))))
+ return MAKMEMO_BEGIN (memoize_exprs (CDDR (expr), env));
+ else
+ return MAKMEMO_QUOTE (SCM_UNSPECIFIED);
+}
+
+static SCM
+scm_m_if (SCM expr, SCM env SCM_UNUSED)
+{
+ const SCM cdr_expr = CDR (expr);
+ const long length = scm_ilength (cdr_expr);
+ ASSERT_SYNTAX (length == 2 || length == 3, s_expression, expr);
+ return MAKMEMO_IF (memoize (CADR (expr), env),
+ memoize (CADDR (expr), env),
+ ((length == 3)
+ ? memoize (CADDDR (expr), env)
+ : MAKMEMO_QUOTE (SCM_UNSPECIFIED)));
+}
+
+/* A helper function for memoize_lambda to support checking for duplicate
+ * formal arguments: Return true if OBJ is `eq?' to one of the elements of
+ * LIST or to the CDR of the last cons. Therefore, LIST may have any of the
+ * forms that a formal argument can have:
+ * <rest>, (<arg1> ...), (<arg1> ... . <rest>) */
+static int
+c_improper_memq (SCM obj, SCM list)
+{
+ for (; scm_is_pair (list); list = CDR (list))
+ {
+ if (scm_is_eq (CAR (list), obj))
+ return 1;
+ }
+ return scm_is_eq (list, obj);
+}
+
+static SCM
+scm_m_lambda (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM formals;
+ SCM formals_idx;
+ SCM formal_vars = SCM_EOL;
+ int nreq = 0;
+
+ const SCM cdr_expr = CDR (expr);
+ const long length = scm_ilength (cdr_expr);
+ ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
+
+ /* Before iterating the list of formal arguments, make sure the formals
+ * actually are given as either a symbol or a non-cyclic list. */
+ formals = CAR (cdr_expr);
+ if (scm_is_pair (formals))
+ {
+ /* Dirk:FIXME:: We should check for a cyclic list of formals, and if
+ * detected, report a 'Bad formals' error. */
+ }
+ else
+ {
+ ASSERT_SYNTAX_2 (scm_is_symbol (formals) || scm_is_null (formals),
+ s_bad_formals, formals, expr);
+ }
+
+ /* Now iterate the list of formal arguments to check if all formals are
+ * symbols, and that there are no duplicates. */
+ formals_idx = formals;
+ while (scm_is_pair (formals_idx))
+ {
+ const SCM formal = CAR (formals_idx);
+ const SCM next_idx = CDR (formals_idx);
+ ASSERT_SYNTAX_2 (scm_is_symbol (formal), s_bad_formal, formal, expr);
+ ASSERT_SYNTAX_2 (!c_improper_memq (formal, next_idx),
+ s_duplicate_formal, formal, expr);
+ nreq++;
+ formal_vars = scm_cons (formal, formal_vars);
+ formals_idx = next_idx;
+ }
+ ASSERT_SYNTAX_2 (scm_is_null (formals_idx) || scm_is_symbol (formals_idx),
+ s_bad_formal, formals_idx, expr);
+ if (scm_is_symbol (formals_idx))
+ formal_vars = scm_cons (formals_idx, formal_vars);
+ return MAKMEMO_LAMBDA (nreq, scm_symbol_p (formals_idx),
+ memoize_sequence (CDDR (expr),
+ memoize_env_extend (env, formal_vars)));
+}
+
+/* Check if the format of the bindings is ((<symbol> <init-form>) ...). */
+static void
+check_bindings (const SCM bindings, const SCM expr)
+{
+ SCM binding_idx;
+
+ ASSERT_SYNTAX_2 (scm_ilength (bindings) >= 0,
+ s_bad_bindings, bindings, expr);
+
+ binding_idx = bindings;
+ for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
+ {
+ SCM name; /* const */
+
+ const SCM binding = CAR (binding_idx);
+ ASSERT_SYNTAX_2 (scm_ilength (binding) == 2,
+ s_bad_binding, binding, expr);
+
+ name = CAR (binding);
+ ASSERT_SYNTAX_2 (scm_is_symbol (name), s_bad_variable, name, expr);
+ }
+}
+
+/* The bindings, which must have the format ((v1 i1) (v2 i2) ... (vn in)), are
+ * transformed to the lists (vn .. v2 v1) and (i1 i2 ... in). If a duplicate
+ * variable name is detected, an error is signalled. */
+static int
+transform_bindings (const SCM bindings, const SCM expr,
+ SCM *const rvarptr, SCM *const initptr)
+{
+ SCM rvariables = SCM_EOL;
+ SCM rinits = SCM_EOL;
+ SCM binding_idx = bindings;
+ int n = 0;
+ for (; !scm_is_null (binding_idx); binding_idx = CDR (binding_idx))
+ {
+ const SCM binding = CAR (binding_idx);
+ const SCM CDR_binding = CDR (binding);
+ const SCM name = CAR (binding);
+ ASSERT_SYNTAX_2 (scm_is_false (scm_c_memq (name, rvariables)),
+ s_duplicate_binding, name, expr);
+ rvariables = scm_cons (name, rvariables);
+ rinits = scm_cons (CAR (CDR_binding), rinits);
+ n++;
+ }
+ *rvarptr = rvariables;
+ *initptr = scm_reverse_x (rinits, SCM_UNDEFINED);
+ return n;
+}
+
+/* This function is a helper function for memoize_let. It transforms
+ * (let name ((var init) ...) body ...) into
+ * ((letrec ((name (lambda (var ...) body ...))) name) init ...)
+ * and memoizes the expression. It is assumed that the caller has checked
+ * that name is a symbol and that there are bindings and a body. */
+static SCM
+memoize_named_let (const SCM expr, SCM env)
+{
+ SCM rvariables;
+ SCM inits;
+ int nreq;
+
+ const SCM cdr_expr = CDR (expr);
+ const SCM name = CAR (cdr_expr);
+ const SCM cddr_expr = CDR (cdr_expr);
+ const SCM bindings = CAR (cddr_expr);
+ check_bindings (bindings, expr);
+
+ nreq = transform_bindings (bindings, expr, &rvariables, &inits);
+
+ env = scm_cons (name, env);
+ return MAKMEMO_LET
+ (scm_list_1 (MAKMEMO_QUOTE (SCM_UNDEFINED)),
+ MAKMEMO_BEGIN
+ (scm_list_2 (MAKMEMO_LEX_SET
+ (0,
+ MAKMEMO_LAMBDA
+ (nreq, SCM_BOOL_F,
+ memoize_sequence (CDDDR (expr),
+ memoize_env_extend (env, rvariables)))),
+ MAKMEMO_CALL (MAKMEMO_LEX_REF (0),
+ memoize_exprs (inits, env)))));
+}
+
+/* (let ((v1 i1) (v2 i2) ...) body) with variables v1 .. vn and initializers
+ * i1 .. in is transformed to (#@let (vn ... v2 v1) (i1 i2 ...) body). */
+static SCM
+scm_m_let (SCM expr, SCM env)
+{
+ SCM bindings;
+
+ const SCM cdr_expr = CDR (expr);
+ const long length = scm_ilength (cdr_expr);
+ ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (length >= 2, s_missing_expression, expr);
+
+ bindings = CAR (cdr_expr);
+ if (scm_is_symbol (bindings))
+ {
+ ASSERT_SYNTAX (length >= 3, s_missing_expression, expr);
+ return memoize_named_let (expr, env);
+ }
+
+ check_bindings (bindings, expr);
+ if (scm_is_null (bindings))
+ return memoize_sequence (CDDR (expr), env);
+ else
+ {
+ SCM rvariables;
+ SCM inits;
+ transform_bindings (bindings, expr, &rvariables, &inits);
+ return MAKMEMO_LET (memoize_exprs (inits, env),
+ memoize_sequence (CDDR (expr),
+ memoize_env_extend (env, rvariables)));
+ }
+}
+
+static SCM
+scm_m_letrec (SCM expr, SCM env)
+{
+ SCM bindings;
+
+ const SCM cdr_expr = 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 = CAR (cdr_expr);
+ if (scm_is_null (bindings))
+ return memoize_sequence (CDDR (expr), env);
+ else
+ {
+ SCM rvariables;
+ SCM inits;
+ SCM v, i;
+ SCM undefs = SCM_EOL;
+ SCM vals = SCM_EOL;
+ SCM sets = SCM_EOL;
+ SCM new_env;
+ int offset;
+ int n = transform_bindings (bindings, expr, &rvariables, &inits);
+ offset = n;
+ new_env = memoize_env_extend (env, rvariables);
+ for (v = scm_reverse (rvariables), i = inits; scm_is_pair (v);
+ v = CDR (v), i = CDR (i), n--)
+ {
+ undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs);
+ vals = scm_cons (memoize (CAR (i), new_env), vals);
+ sets = scm_cons (MAKMEMO_LEX_SET ((n-1) + offset,
+ MAKMEMO_LEX_REF (n-1)),
+ sets);
+ }
+ return MAKMEMO_LET
+ (undefs,
+ MAKMEMO_BEGIN (scm_list_2 (MAKMEMO_LET (scm_reverse (vals),
+ MAKMEMO_BEGIN (sets)),
+ memoize_sequence (CDDR (expr),
+ new_env))));
+ }
+}
+
+static SCM
+scm_m_letstar (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM bindings;
+
+ const SCM cdr_expr = 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 = CAR (cdr_expr);
+ if (scm_is_null (bindings))
+ return memoize_sequence (CDDR (expr), env);
+ else
+ {
+ SCM rvariables;
+ SCM variables;
+ SCM inits;
+ SCM ret, loc;
+ transform_bindings (bindings, expr, &rvariables, &inits);
+ variables = scm_reverse (rvariables);
+ ret = scm_cons (SCM_UNDEFINED, SCM_UNSPECIFIED);
+ loc = ret;
+ for (; scm_is_pair (variables);
+ variables = CDR (variables), inits = CDR (inits))
+ { SCM x = MAKMEMO_LET (scm_list_1 (memoize (CAR (inits), env)),
+ MAKMEMO_QUOTE (SCM_UNSPECIFIED));
+ SCM_SETCDR (loc, x);
+ loc = scm_last_pair (SCM_MEMOIZED_ARGS (x));
+ env = scm_cons (CAR (variables), env);
+ }
+ SCM_SETCDR (loc, memoize_sequence (CDDR (expr), env));
+ return CDR (ret);
+ }
+}
+
+static SCM
+scm_m_or (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM tail = CDR (expr);
+ SCM ret, loc;
+ const long length = scm_ilength (tail);
+
+ ASSERT_SYNTAX (length >= 0, s_bad_expression, expr);
+
+ ret = scm_cons (SCM_UNDEFINED, SCM_UNSPECIFIED);
+ loc = ret;
+ for (; scm_is_pair (tail); tail = CDR (tail))
+ {
+ SCM tmp = scm_gensym (scm_from_locale_string ("cond "));
+ SCM x = MAKMEMO_IF (MAKMEMO_LEX_REF (0),
+ MAKMEMO_LEX_REF (0),
+ MAKMEMO_QUOTE (SCM_UNSPECIFIED));
+ SCM new_env = scm_cons (tmp, env);
+ SCM_SETCDR (loc, MAKMEMO_LET (scm_list_1 (memoize (CAR (tail),
+ env)),
+ x));
+ env = new_env;
+ loc = scm_last_pair (SCM_MEMOIZED_ARGS (x));
+ }
+ SCM_SETCDR (loc, MAKMEMO_QUOTE (SCM_BOOL_F));
+ return CDR (ret);
+}
+
+static SCM
+scm_m_quote (SCM expr, SCM env SCM_UNUSED)
+{
+ SCM quotee;
+
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 1, s_expression, expr);
+ quotee = CAR (cdr_expr);
+ return MAKMEMO_QUOTE (quotee);
+}
+
+static SCM
+scm_m_set_x (SCM expr, SCM env)
+{
+ SCM variable;
+ SCM vmem;
+
+ const SCM cdr_expr = CDR (expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) >= 0, s_bad_expression, expr);
+ ASSERT_SYNTAX (scm_ilength (cdr_expr) == 2, s_expression, expr);
+ variable = CAR (cdr_expr);
+ vmem = memoize (variable, env);
+
+ switch (SCM_MEMOIZED_TAG (vmem))
+ {
+ case SCM_M_LEXICAL_REF:
+ return MAKMEMO_LEX_SET (SCM_I_INUM (SCM_MEMOIZED_ARGS (vmem)),
+ memoize (CADDR (expr), env));
+ case SCM_M_TOPLEVEL_REF:
+ return MAKMEMO_TOP_SET (variable,
+ memoize (CADDR (expr), env));
+ case SCM_M_MODULE_REF:
+ return MAKMEMO_MOD_SET (memoize (CADDR (expr), env),
+ CAR (SCM_MEMOIZED_ARGS (vmem)),
+ CADR (SCM_MEMOIZED_ARGS (vmem)),
+ CDDR (SCM_MEMOIZED_ARGS (vmem)));
+ default:
+ syntax_error (s_bad_variable, variable, expr);
+ }
+}
+
+
+
+
+SCM_DEFINE (scm_memoize_expression, "memoize-expression", 1, 0, 0,
+ (SCM exp),
+ "Memoize the expression @var{exp}.")
+#define FUNC_NAME s_scm_memoize_expression
+{
+ return memoize (exp, scm_current_module ());
+}
+#undef FUNC_NAME
+
+
+
+
+SCM_SYMBOL (sym_placeholder, "_");
+
+static SCM unmemoize (SCM expr);
+
+static SCM
+unmemoize_exprs (SCM exprs)
+{
+ SCM ret, tail;
+ if (scm_is_null (exprs))
+ return SCM_EOL;
+ ret = scm_list_1 (unmemoize (CAR (exprs)));
+ tail = ret;
+ for (exprs = CDR (exprs); !scm_is_null (exprs); exprs = CDR (exprs))
+ {
+ SCM_SETCDR (tail, scm_list_1 (unmemoize (CAR (exprs))));
+ tail = CDR (tail);
+ }
+ return ret;
+}
+
+static SCM
+unmemoize_bindings (SCM inits)
+{
+ SCM ret, tail;
+ if (scm_is_null (inits))
+ return SCM_EOL;
+ ret = scm_list_1 (scm_list_2 (sym_placeholder, unmemoize (CAR (inits))));
+ tail = ret;
+ for (inits = CDR (inits); !scm_is_null (inits); inits = CDR (inits))
+ {
+ SCM_SETCDR (tail, scm_list_1 (scm_list_2 (sym_placeholder,
+ unmemoize (CAR (inits)))));
+ tail = CDR (tail);
+ }
+ return ret;
+}
+
+static SCM
+unmemoize_lexical (SCM n)
+{
+ char buf[16];
+ buf[15] = 0;
+ snprintf (buf, 15, "<%u>", scm_to_uint32 (n));
+ return scm_from_locale_symbol (buf);
+}
+
+static SCM
+unmemoize (const SCM expr)
+{
+ SCM args;
+
+ if (!SCM_MEMOIZED_P (expr))
+ abort ();
+
+ args = SCM_MEMOIZED_ARGS (expr);
+ switch (SCM_MEMOIZED_TAG (expr))
+ {
+ case SCM_M_APPLY:
+ return scm_cons (scm_sym_atapply, unmemoize_exprs (args));
+ case SCM_M_BEGIN:
+ return scm_cons (scm_sym_begin, unmemoize_exprs (args));
+ case SCM_M_CALL:
+ return unmemoize_exprs (args);
+ case SCM_M_CONT:
+ return scm_list_2 (scm_sym_atcall_cc, unmemoize (args));
+ case SCM_M_CALL_WITH_VALUES:
+ return scm_list_3 (scm_sym_at_call_with_values,
+ unmemoize (CAR (args)), unmemoize (CDR (args)));
+ case SCM_M_DEFINE:
+ return scm_list_3 (scm_sym_define, CAR (args), unmemoize (CDR (args)));
+ case SCM_M_IF:
+ return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)),
+ unmemoize (scm_cadr (args)), unmemoize (scm_cddr (args)));
+ case SCM_M_LAMBDA:
+ return scm_list_3 (scm_sym_lambda,
+ scm_make_list (CAR (args), sym_placeholder),
+ unmemoize (CDDR (args)));
+ case SCM_M_LET:
+ return scm_list_3 (scm_sym_let,
+ unmemoize_bindings (CAR (args)),
+ unmemoize (CDR (args)));
+ case SCM_M_QUOTE:
+ return scm_list_2 (scm_sym_quote, args);
+ case SCM_M_LEXICAL_REF:
+ return unmemoize_lexical (args);
+ case SCM_M_LEXICAL_SET:
+ return scm_list_3 (scm_sym_set_x, unmemoize_lexical (CAR (args)),
+ unmemoize (CDR (args)));
+ case SCM_M_TOPLEVEL_REF:
+ return args;
+ case SCM_M_TOPLEVEL_SET:
+ return scm_list_3 (scm_sym_set_x, CAR (args), unmemoize (CDR (args)));
+ case SCM_M_MODULE_REF:
+ return scm_list_3 (scm_is_true (CDDR (args)) ? scm_sym_at : scm_sym_atat,
+ scm_i_finite_list_copy (CAR (args)),
+ CADR (args));
+ case SCM_M_MODULE_SET:
+ return scm_list_3 (scm_sym_set_x,
+ scm_list_3 (scm_is_true (CDDDR (args))
+ ? scm_sym_at : scm_sym_atat,
+ scm_i_finite_list_copy (CADR (args)),
+ CADDR (args)),
+ unmemoize (CAR (args)));
+ default:
+ abort ();
+ }
+}
+
+SCM_DEFINE (scm_memoized_p, "memoized?", 1, 0, 0,
+ (SCM obj),
+ "Return @code{#t} if @var{obj} is memoized.")
+#define FUNC_NAME s_scm_memoized_p
+{
+ return scm_from_bool (SCM_MEMOIZED_P (obj));
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_unmemoize_expression, "unmemoize-expression", 1, 0, 0,
+ (SCM m),
+ "Unmemoize the memoized expression @var{m}.")
+#define FUNC_NAME s_scm_unmemoize_expression
+{
+ SCM_VALIDATE_MEMOIZED (1, m);
+ return unmemoize (m);
+}
+#undef FUNC_NAME
+
+
+
+
+void
+scm_init_memoize ()
+{
+ scm_tc16_memoized = scm_make_smob_type ("%memoized", 0);
+ scm_set_smob_mark (scm_tc16_memoized, scm_markcdr);
+ scm_set_smob_print (scm_tc16_memoized, scm_print_memoized);
+
+#include "libguile/memoize.x"
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/