diff options
Diffstat (limited to 'libguile/memoize.c')
-rw-r--r-- | libguile/memoize.c | 1141 |
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: +*/ |