X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/3149a5b60de3dc55c7349aba5bfb3ff28c594aef..bb0229b51d53c10164f58cebbeeed85cd9dfe0b8:/libguile/memoize.c diff --git a/libguile/memoize.c b/libguile/memoize.c index 0574e1197..4c1a1017b 100644 --- a/libguile/memoize.c +++ b/libguile/memoize.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009 +/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010 * Free Software Foundation, Inc. * * This library is free software; you can redistribute it and/or @@ -23,11 +23,7 @@ # include #endif -#include - #include "libguile/__scm.h" - -#include #include "libguile/_scm.h" #include "libguile/continuations.h" #include "libguile/eq.h" @@ -203,14 +199,18 @@ scm_t_bits scm_tc16_memoized; MAKMEMO (SCM_M_QUOTE, exp) #define MAKMEMO_DEFINE(var, val) \ MAKMEMO (SCM_M_DEFINE, scm_cons (var, val)) +#define MAKMEMO_DYNWIND(in, expr, out) \ + MAKMEMO (SCM_M_DYNWIND, scm_cons (in, scm_cons (expr, out))) +#define MAKMEMO_WITH_FLUIDS(fluids, vals, expr) \ + MAKMEMO (SCM_M_WITH_FLUIDS, scm_cons (fluids, scm_cons (vals, expr))) #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_CALL(proc, nargs, args) \ + MAKMEMO (SCM_M_CALL, scm_cons (proc, scm_cons (SCM_I_MAKINUM (nargs), args))) #define MAKMEMO_LEX_REF(n) \ MAKMEMO (SCM_M_LEXICAL_REF, SCM_I_MAKINUM (n)) #define MAKMEMO_LEX_SET(n, val) \ @@ -235,6 +235,8 @@ static const char *const memoized_tags[] = "let", "quote", "define", + "dynwind", + "with-fluids", "apply", "call/cc", "call-with-values", @@ -265,6 +267,8 @@ 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_at_dynamic_wind (SCM xorig, SCM env); +static SCM scm_m_with_fluids (SCM xorig, SCM env); static SCM scm_m_eval_when (SCM xorig, SCM env); static SCM scm_m_if (SCM xorig, SCM env); static SCM scm_m_lambda (SCM xorig, SCM env); @@ -279,9 +283,7 @@ static SCM scm_m_set_x (SCM xorig, SCM env); -typedef SCM (*t_syntax_transformer) (SCM, SCM); - -static t_syntax_transformer +static scm_t_macro_primitive memoize_env_ref_transformer (SCM env, SCM x) { SCM var; @@ -291,15 +293,8 @@ memoize_env_ref_transformer (SCM env, SCM x) 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 */ - } + && scm_is_true (scm_macro_p (scm_variable_ref (var)))) + return scm_i_macro_primitive (scm_variable_ref (var)); else return NULL; /* anything else */ } @@ -335,7 +330,7 @@ memoize (SCM exp, SCM env) if (scm_is_pair (exp)) { SCM CAR; - t_syntax_transformer trans; + scm_t_macro_primitive trans; CAR = CAR (exp); if (scm_is_symbol (CAR)) @@ -347,11 +342,15 @@ memoize (SCM exp, SCM env) return trans (exp, env); else { + SCM proc; SCM args = SCM_EOL; - for (; scm_is_pair (exp); exp = CDR (exp)) + int nargs = 0; + proc = memoize (CAR (exp), env); + for (exp = CDR (exp); scm_is_pair (exp); exp = CDR (exp), nargs++) args = scm_cons (memoize (CAR (exp), env), args); if (scm_is_null (exp)) - return MAKMEMO (SCM_M_CALL, scm_reverse_x (args, SCM_UNDEFINED)); + return MAKMEMO_CALL (proc, nargs, + scm_reverse_x (args, SCM_UNDEFINED)); else syntax_error ("expected a proper list", exp, SCM_UNDEFINED); } @@ -383,34 +382,40 @@ 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)); + if (scm_is_null (CDR (forms))) + return memoize (CAR (forms), env); + else + 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); +#define SCM_SYNTAX(RANAME, STR, CFN) \ +SCM_SNARF_HERE(static const char RANAME[]=STR)\ +SCM_SNARF_INIT(scm_c_define (RANAME, scm_i_make_primitive_macro (RANAME, CFN))) + +SCM_SYNTAX (s_at, "@", scm_m_at); +SCM_SYNTAX (s_atat, "@@", scm_m_atat); +SCM_SYNTAX (s_and, "and", scm_m_and); +SCM_SYNTAX (s_begin, "begin", scm_m_begin); +SCM_SYNTAX (s_atcall_cc, "@call-with-current-continuation", scm_m_cont); +SCM_SYNTAX (s_at_call_with_values, "@call-with-values", scm_m_at_call_with_values); +SCM_SYNTAX (s_cond, "cond", scm_m_cond); +SCM_SYNTAX (s_define, "define", scm_m_define); +SCM_SYNTAX (s_at_dynamic_wind, "@dynamic-wind", scm_m_at_dynamic_wind); +SCM_SYNTAX (s_with_fluids, "with-fluids", scm_m_with_fluids); +SCM_SYNTAX (s_eval_when, "eval-when", scm_m_eval_when); +SCM_SYNTAX (s_if, "if", scm_m_if); +SCM_SYNTAX (s_lambda, "lambda", scm_m_lambda); +SCM_SYNTAX (s_let, "let", scm_m_let); +SCM_SYNTAX (s_letrec, "letrec", scm_m_letrec); +SCM_SYNTAX (s_letstar, "let*", scm_m_letstar); +SCM_SYNTAX (s_or, "or", scm_m_or); +SCM_SYNTAX (s_quote, "quote", scm_m_quote); +SCM_SYNTAX (s_set_x, "set!", scm_m_set_x); +SCM_SYNTAX (s_atapply, "@apply", scm_m_apply); SCM_GLOBAL_SYMBOL (scm_sym_apply, "apply"); @@ -424,6 +429,8 @@ 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_at_dynamic_wind, "@dynamic-wind"); +SCM_GLOBAL_SYMBOL (scm_sym_with_fluids, "with-fluids"); SCM_GLOBAL_SYMBOL (scm_sym_else, "else"); SCM_GLOBAL_SYMBOL (scm_sym_eval_when, "eval-when"); SCM_GLOBAL_SYMBOL (scm_sym_if, "if"); @@ -568,6 +575,7 @@ scm_m_cond (SCM expr, SCM env) i = MAKMEMO_IF (MAKMEMO_LEX_REF (0), MAKMEMO_CALL (memoize (CADDR (clause), scm_cons (tmp, new_env)), + 1, scm_list_1 (MAKMEMO_LEX_REF (0))), MAKMEMO_QUOTE (SCM_UNSPECIFIED)); SCM_SETCDR (loc, @@ -622,6 +630,40 @@ scm_m_define (SCM expr, SCM env) return MAKMEMO_DEFINE (variable, memoize (CAR (body), env)); } +static SCM +scm_m_at_dynamic_wind (SCM expr, SCM env) +{ + const SCM cdr_expr = CDR (expr); + ASSERT_SYNTAX (scm_ilength (cdr_expr) == 3, s_bad_expression, expr); + + return MAKMEMO_DYNWIND (memoize (CADR (expr), env), + memoize (CADDR (expr), env), + memoize (CADDDR (expr), env)); +} + +static SCM +scm_m_with_fluids (SCM expr, SCM env) +{ + SCM binds, fluids, vals; + ASSERT_SYNTAX (scm_ilength (expr) >= 3, s_bad_expression, expr); + binds = CADR (expr); + ASSERT_SYNTAX_2 (scm_ilength (binds) >= 0, s_bad_bindings, binds, expr); + for (fluids = SCM_EOL, vals = SCM_EOL; + scm_is_pair (binds); + binds = CDR (binds)) + { + SCM binding = CAR (binds); + ASSERT_SYNTAX_2 (scm_ilength (CAR (binds)) == 2, s_bad_binding, + binding, expr); + fluids = scm_cons (memoize (CAR (binding), env), fluids); + vals = scm_cons (memoize (CADR (binding), env), vals); + } + + return MAKMEMO_WITH_FLUIDS (scm_reverse_x (fluids, SCM_UNDEFINED), + scm_reverse_x (vals, SCM_UNDEFINED), + memoize_sequence (CDDR (expr), env)); +} + static SCM scm_m_eval_when (SCM expr, SCM env) { @@ -795,6 +837,7 @@ memoize_named_let (const SCM expr, SCM env) memoize_sequence (CDDDR (expr), memoize_env_extend (env, rvariables)))), MAKMEMO_CALL (MAKMEMO_LEX_REF (0), + nreq, memoize_exprs (inits, env))))); } @@ -1056,7 +1099,7 @@ unmemoize (const SCM expr) case SCM_M_BEGIN: return scm_cons (scm_sym_begin, unmemoize_exprs (args)); case SCM_M_CALL: - return unmemoize_exprs (args); + return scm_cons (unmemoize (CAR (args)), unmemoize_exprs (CDDR (args))); case SCM_M_CONT: return scm_list_2 (scm_sym_atcall_cc, unmemoize (args)); case SCM_M_CALL_WITH_VALUES: @@ -1064,6 +1107,23 @@ unmemoize (const SCM expr) 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_DYNWIND: + return scm_list_4 (scm_sym_at_dynamic_wind, + unmemoize (CAR (args)), + unmemoize (CADR (args)), + unmemoize (CDDR (args))); + case SCM_M_WITH_FLUIDS: + { + SCM binds = SCM_EOL, fluids, vals; + for (fluids = CAR (args), vals = CADR (args); scm_is_pair (fluids); + fluids = CDR (fluids), vals = CDR (vals)) + binds = scm_cons (scm_list_2 (unmemoize (CAR (fluids)), + unmemoize (CAR (vals))), + binds); + return scm_list_3 (scm_sym_with_fluids, + scm_reverse_x (binds, SCM_UNDEFINED), + unmemoize (CDDR (args))); + } case SCM_M_IF: return scm_list_4 (scm_sym_if, unmemoize (scm_car (args)), unmemoize (scm_cadr (args)), unmemoize (scm_cddr (args))); @@ -1087,15 +1147,17 @@ unmemoize (const SCM expr) 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)); + return SCM_VARIABLEP (args) ? args + : 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)), + SCM_VARIABLEP (CDR (args)) ? CDR (args) + : 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 (); @@ -1169,7 +1231,7 @@ static void error_unbound_variable (SCM symbol) SCM_DEFINE (scm_memoize_variable_access_x, "memoize-variable-access!", 2, 0, 0, (SCM m, SCM mod), "Look up and cache the variable that @var{m} will access, returning the variable.") -#define FUNC_NAME s_scm_memoized_expression_data +#define FUNC_NAME s_scm_memoize_variable_access_x { SCM mx; SCM_VALIDATE_MEMOIZED (1, m);