-/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013
- * 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
- */
-
-\f
-
-#ifdef HAVE_CONFIG_H
-# include <config.h>
-#endif
-
-#include "libguile/__scm.h"
-#include "libguile/_scm.h"
-#include "libguile/continuations.h"
-#include "libguile/eq.h"
-#include "libguile/expand.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"
-
-
-\f
-
-
-#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)
-
-
-SCM_SYMBOL (sym_case_lambda_star, "case-lambda*");
-
-\f
-
-
-/* {Evaluator memoized expressions}
- */
-
-scm_t_bits scm_tc16_memoized;
-
-#define MAKMEMO(n, args) \
- (scm_cell (scm_tc16_memoized | ((n) << 16), SCM_UNPACK (args)))
-
-#define MAKMEMO_SEQ(head,tail) \
- MAKMEMO (SCM_M_SEQ, scm_cons (head, tail))
-#define MAKMEMO_IF(test, then, else_) \
- MAKMEMO (SCM_M_IF, scm_cons (test, scm_cons (then, else_)))
-#define FIXED_ARITY(nreq) \
- scm_list_1 (SCM_I_MAKINUM (nreq))
-#define REST_ARITY(nreq, rest) \
- scm_list_2 (SCM_I_MAKINUM (nreq), rest)
-#define FULL_ARITY(nreq, rest, nopt, kw, inits, alt) \
- scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, inits, \
- alt, SCM_UNDEFINED)
-#define MAKMEMO_LAMBDA(body, arity, docstring) \
- MAKMEMO (SCM_M_LAMBDA, \
- scm_cons (body, scm_cons (docstring, arity)))
-#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_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(proc, args)\
- MAKMEMO (SCM_M_APPLY, scm_list_2 (proc, args))
-#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, 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) \
- 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))))
-#define MAKMEMO_PROMPT(tag, exp, handler) \
- MAKMEMO (SCM_M_PROMPT, scm_cons (tag, scm_cons (exp, handler)))
-
-
-/* Primitives for the evaluator */
-scm_t_bits scm_tc16_memoizer;
-#define SCM_MEMOIZER_P(x) (SCM_SMOB_PREDICATE (scm_tc16_memoizer, (x)))
-#define SCM_MEMOIZER(M) (SCM_SMOB_OBJECT_1 (M))
-
-\f
-
-/* This table must agree with the list of M_ constants in memoize.h */
-static const char *const memoized_tags[] =
-{
- "seq",
- "if",
- "lambda",
- "let",
- "quote",
- "define",
- "dynwind",
- "with-fluids",
- "apply",
- "call/cc",
- "call-with-values",
- "call",
- "lexical-ref",
- "lexical-set!",
- "toplevel-ref",
- "toplevel-set!",
- "module-ref",
- "module-set!",
- "prompt",
-};
-
-static int
-scm_print_memoized (SCM memoized, SCM port, scm_print_state *pstate)
-{
- scm_puts_unlocked ("#<memoized ", port);
- scm_write (scm_unmemoize_expression (memoized), port);
- scm_puts_unlocked (">", port);
- return 1;
-}
-
-
-\f
-
-
-static int
-lookup (SCM x, SCM env)
-{
- int i = 0;
- for (; scm_is_pair (env); env = CDR (env), i++)
- if (scm_is_eq (x, CAR (env)))
- return i; /* bound */
- abort ();
-}
-
-
-/* Abbreviate SCM_EXPANDED_REF. Copied because I'm not sure about symbol pasting */
-#define REF(x,type,field) \
- (scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field)))
-
-static SCM list_of_guile = SCM_BOOL_F;
-
-static SCM memoize (SCM exp, SCM env);
-
-static SCM
-memoize_exps (SCM exps, SCM env)
-{
- SCM ret;
- for (ret = SCM_EOL; scm_is_pair (exps); exps = CDR (exps))
- ret = scm_cons (memoize (CAR (exps), env), ret);
- return scm_reverse_x (ret, SCM_UNDEFINED);
-}
-
-static SCM
-memoize (SCM exp, SCM env)
-{
- if (!SCM_EXPANDED_P (exp))
- abort ();
-
- switch (SCM_EXPANDED_TYPE (exp))
- {
- case SCM_EXPANDED_VOID:
- return MAKMEMO_QUOTE (SCM_UNSPECIFIED);
-
- case SCM_EXPANDED_CONST:
- return MAKMEMO_QUOTE (REF (exp, CONST, EXP));
-
- case SCM_EXPANDED_PRIMITIVE_REF:
- if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
- return MAKMEMO_TOP_REF (REF (exp, PRIMITIVE_REF, NAME));
- else
- return MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMITIVE_REF, NAME),
- SCM_BOOL_F);
-
- case SCM_EXPANDED_LEXICAL_REF:
- return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env));
-
- case SCM_EXPANDED_LEXICAL_SET:
- return MAKMEMO_LEX_SET (lookup (REF (exp, LEXICAL_SET, GENSYM), env),
- memoize (REF (exp, LEXICAL_SET, EXP), env));
-
- case SCM_EXPANDED_MODULE_REF:
- return MAKMEMO_MOD_REF (REF (exp, MODULE_REF, MOD),
- REF (exp, MODULE_REF, NAME),
- REF (exp, MODULE_REF, PUBLIC));
-
- case SCM_EXPANDED_MODULE_SET:
- return MAKMEMO_MOD_SET (memoize (REF (exp, MODULE_SET, EXP), env),
- REF (exp, MODULE_SET, MOD),
- REF (exp, MODULE_SET, NAME),
- REF (exp, MODULE_SET, PUBLIC));
-
- case SCM_EXPANDED_TOPLEVEL_REF:
- return MAKMEMO_TOP_REF (REF (exp, TOPLEVEL_REF, NAME));
-
- case SCM_EXPANDED_TOPLEVEL_SET:
- return MAKMEMO_TOP_SET (REF (exp, TOPLEVEL_SET, NAME),
- memoize (REF (exp, TOPLEVEL_SET, EXP), env));
-
- case SCM_EXPANDED_TOPLEVEL_DEFINE:
- return MAKMEMO_DEFINE (REF (exp, TOPLEVEL_DEFINE, NAME),
- memoize (REF (exp, TOPLEVEL_DEFINE, EXP), env));
-
- case SCM_EXPANDED_CONDITIONAL:
- return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env),
- memoize (REF (exp, CONDITIONAL, CONSEQUENT), env),
- memoize (REF (exp, CONDITIONAL, ALTERNATE), env));
-
- case SCM_EXPANDED_CALL:
- {
- SCM proc, args;
-
- proc = REF (exp, CALL, PROC);
- args = memoize_exps (REF (exp, CALL, ARGS), env);
-
- if (SCM_EXPANDED_TYPE (proc) == SCM_EXPANDED_TOPLEVEL_REF)
- {
- SCM var = scm_module_variable (scm_current_module (),
- REF (proc, TOPLEVEL_REF, NAME));
- if (SCM_VARIABLEP (var))
- {
- SCM val = SCM_VARIABLE_REF (var);
- if (SCM_MEMOIZER_P (val))
- return scm_apply (SCM_SMOB_OBJECT_1 (val), args, SCM_EOL);
- }
- }
- /* otherwise we all fall down here */
- return MAKMEMO_CALL (memoize (proc, env), scm_ilength (args), args);
- }
-
- case SCM_EXPANDED_PRIMCALL:
- {
- SCM proc, args;
-
- if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
- proc = MAKMEMO_TOP_REF (REF (exp, PRIMCALL, NAME));
- else
- proc = MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMCALL, NAME),
- SCM_BOOL_F);
- args = memoize_exps (REF (exp, PRIMCALL, ARGS), env);
-
- return MAKMEMO_CALL (proc, scm_ilength (args), args);
- }
-
- case SCM_EXPANDED_SEQ:
- return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env),
- memoize (REF (exp, SEQ, TAIL), env));
-
- case SCM_EXPANDED_LAMBDA:
- /* The body will be a lambda-case or #f. */
- {
- SCM meta, docstring, body, proc;
-
- meta = REF (exp, LAMBDA, META);
- docstring = scm_assoc_ref (meta, scm_sym_documentation);
-
- body = REF (exp, LAMBDA, BODY);
- if (scm_is_false (body))
- /* Give a body to case-lambda with no clauses. */
- proc = MAKMEMO_LAMBDA
- (MAKMEMO_CALL
- (MAKMEMO_MOD_REF (list_of_guile,
- scm_from_latin1_symbol ("throw"),
- SCM_BOOL_F),
- 5,
- scm_list_5 (MAKMEMO_QUOTE (scm_args_number_key),
- MAKMEMO_QUOTE (SCM_BOOL_F),
- MAKMEMO_QUOTE (scm_from_latin1_string
- ("Wrong number of arguments")),
- MAKMEMO_QUOTE (SCM_EOL),
- MAKMEMO_QUOTE (SCM_BOOL_F))),
- FIXED_ARITY (0),
- SCM_BOOL_F /* docstring */);
- else
- proc = memoize (body, env);
-
- if (scm_is_string (docstring))
- {
- SCM args = SCM_MEMOIZED_ARGS (proc);
- SCM_SETCAR (SCM_CDR (args), docstring);
- }
-
- return proc;
- }
-
- case SCM_EXPANDED_LAMBDA_CASE:
- {
- SCM req, rest, opt, kw, inits, vars, body, alt;
- SCM walk, minits, arity, new_env;
- int nreq, nopt, ntotal;
-
- req = REF (exp, LAMBDA_CASE, REQ);
- rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST)));
- opt = REF (exp, LAMBDA_CASE, OPT);
- kw = REF (exp, LAMBDA_CASE, KW);
- inits = REF (exp, LAMBDA_CASE, INITS);
- vars = REF (exp, LAMBDA_CASE, GENSYMS);
- body = REF (exp, LAMBDA_CASE, BODY);
- alt = REF (exp, LAMBDA_CASE, ALTERNATE);
-
- nreq = scm_ilength (req);
- nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0;
- ntotal = scm_ilength (vars);
-
- /* The vars are the gensyms, according to the divine plan. But we need
- to memoize the inits within their appropriate environment,
- complicating things. */
- new_env = env;
- for (walk = req; scm_is_pair (walk);
- walk = CDR (walk), vars = CDR (vars))
- new_env = scm_cons (CAR (vars), new_env);
-
- minits = SCM_EOL;
- for (walk = opt; scm_is_pair (walk);
- walk = CDR (walk), vars = CDR (vars), inits = CDR (inits))
- {
- minits = scm_cons (memoize (CAR (inits), new_env), minits);
- new_env = scm_cons (CAR (vars), new_env);
- }
-
- if (scm_is_true (rest))
- {
- new_env = scm_cons (CAR (vars), new_env);
- vars = CDR (vars);
- }
-
- for (; scm_is_pair (inits); vars = CDR (vars), inits = CDR (inits))
- {
- minits = scm_cons (memoize (CAR (inits), new_env), minits);
- new_env = scm_cons (CAR (vars), new_env);
- }
- if (!scm_is_null (vars))
- abort ();
-
- minits = scm_reverse_x (minits, SCM_UNDEFINED);
-
- if (scm_is_true (kw))
- {
- /* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */
- SCM aok = CAR (kw), indices = SCM_EOL;
- for (kw = CDR (kw); scm_is_pair (kw); kw = CDR (kw))
- {
- SCM k;
- int idx;
-
- k = CAR (CAR (kw));
- idx = ntotal - 1 - lookup (CADDR (CAR (kw)), new_env);
- indices = scm_acons (k, SCM_I_MAKINUM (idx), indices);
- }
- kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED));
- }
-
- if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt))
- {
- if (scm_is_false (rest))
- arity = FIXED_ARITY (nreq);
- else
- arity = REST_ARITY (nreq, SCM_BOOL_T);
- }
- else if (scm_is_true (alt))
- arity = FULL_ARITY (nreq, rest, nopt, kw, minits,
- SCM_MEMOIZED_ARGS (memoize (alt, env)));
- else
- arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F);
-
- return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
- SCM_BOOL_F /* docstring */);
- }
-
- case SCM_EXPANDED_LET:
- {
- SCM vars, exps, body, inits, new_env;
-
- vars = REF (exp, LET, GENSYMS);
- exps = REF (exp, LET, VALS);
- body = REF (exp, LET, BODY);
-
- inits = SCM_EOL;
- new_env = env;
- for (; scm_is_pair (vars); vars = CDR (vars), exps = CDR (exps))
- {
- new_env = scm_cons (CAR (vars), new_env);
- inits = scm_cons (memoize (CAR (exps), env), inits);
- }
-
- return MAKMEMO_LET (scm_reverse_x (inits, SCM_UNDEFINED),
- memoize (body, new_env));
- }
-
- case SCM_EXPANDED_LETREC:
- {
- SCM vars, exps, body, undefs, new_env;
- int i, nvars, in_order_p;
-
- vars = REF (exp, LETREC, GENSYMS);
- exps = REF (exp, LETREC, VALS);
- body = REF (exp, LETREC, BODY);
- in_order_p = scm_is_true (REF (exp, LETREC, IN_ORDER_P));
- nvars = i = scm_ilength (vars);
- undefs = SCM_EOL;
- new_env = env;
-
- for (; scm_is_pair (vars); vars = CDR (vars))
- {
- new_env = scm_cons (CAR (vars), new_env);
- undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs);
- }
-
- if (in_order_p)
- {
- SCM body_exps = SCM_EOL, seq;
- for (; scm_is_pair (exps); exps = CDR (exps), i--)
- body_exps = scm_cons (MAKMEMO_LEX_SET (i-1,
- memoize (CAR (exps), new_env)),
- body_exps);
-
- seq = memoize (body, new_env);
- for (; scm_is_pair (body_exps); body_exps = CDR (body_exps))
- seq = MAKMEMO_SEQ (CAR (body_exps), seq);
-
- return MAKMEMO_LET (undefs, seq);
- }
- else
- {
- SCM sets = SCM_EOL, inits = SCM_EOL, set_seq;
- for (; scm_is_pair (exps); exps = CDR (exps), i--)
- {
- sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars,
- MAKMEMO_LEX_REF (i-1)),
- sets);
- inits = scm_cons (memoize (CAR (exps), new_env), inits);
- }
- inits = scm_reverse_x (inits, SCM_UNDEFINED);
-
- sets = scm_reverse_x (sets, SCM_UNDEFINED);
- if (scm_is_null (sets))
- return memoize (body, env);
-
- for (set_seq = CAR (sets), sets = CDR (sets); scm_is_pair (sets);
- sets = CDR (sets))
- set_seq = MAKMEMO_SEQ (CAR (sets), set_seq);
-
- return MAKMEMO_LET (undefs,
- MAKMEMO_SEQ (MAKMEMO_LET (inits, set_seq),
- memoize (body, new_env)));
- }
- }
-
- case SCM_EXPANDED_DYNLET:
- return MAKMEMO_WITH_FLUIDS (memoize_exps (REF (exp, DYNLET, FLUIDS), env),
- memoize_exps (REF (exp, DYNLET, VALS), env),
- memoize (REF (exp, DYNLET, BODY), env));
-
- default:
- abort ();
- }
-}
-
-
-\f
-
-SCM_DEFINE (scm_memoize_expression, "memoize-expression", 1, 0, 0,
- (SCM exp),
- "Memoize the expression @var{exp}.")
-#define FUNC_NAME s_scm_memoize_expression
-{
- SCM_ASSERT_TYPE (SCM_EXPANDED_P (exp), exp, 1, FUNC_NAME, "expanded");
- return memoize (exp, scm_current_module ());
-}
-#undef FUNC_NAME
-
-
-\f
-
-#define SCM_MAKE_MEMOIZER(STR, MEMOIZER, N) \
- (scm_cell (scm_tc16_memoizer, \
- SCM_UNPACK (scm_c_make_gsubr (STR, N, 0, 0, MEMOIZER))))
-#define SCM_DEFINE_MEMOIZER(STR, MEMOIZER, N) \
-SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_MEMOIZER (STR, MEMOIZER, N)))
-
-#define SCM_MAKE_REST_MEMOIZER(STR, MEMOIZER, N) \
- (scm_cell (scm_tc16_memoizer, \
- SCM_UNPACK ((scm_c_make_gsubr (STR, N, 0, 1, MEMOIZER)))))
-#define SCM_DEFINE_REST_MEMOIZER(STR, MEMOIZER, N) \
-SCM_SNARF_INIT(scm_c_define (STR, SCM_MAKE_REST_MEMOIZER (STR, MEMOIZER, N)))
-
-static SCM m_apply (SCM proc, SCM arg, SCM rest);
-static SCM m_call_cc (SCM proc);
-static SCM m_call_values (SCM prod, SCM cons);
-static SCM m_dynamic_wind (SCM pre, SCM exp, SCM post);
-static SCM m_prompt (SCM tag, SCM exp, SCM handler);
-
-SCM_DEFINE_REST_MEMOIZER ("@apply", m_apply, 2);
-SCM_DEFINE_MEMOIZER ("@call-with-current-continuation", m_call_cc, 1);
-SCM_DEFINE_MEMOIZER ("@call-with-values", m_call_values, 2);
-SCM_DEFINE_MEMOIZER ("@dynamic-wind", m_dynamic_wind, 3);
-SCM_DEFINE_MEMOIZER ("@prompt", m_prompt, 3);
-
-
-\f
-
-static SCM m_apply (SCM proc, SCM arg, SCM rest)
-#define FUNC_NAME "@apply"
-{
- long len;
-
- SCM_VALIDATE_MEMOIZED (1, proc);
- SCM_VALIDATE_MEMOIZED (2, arg);
- len = scm_ilength (rest);
- if (len < 0)
- abort ();
- else if (len == 0)
- return MAKMEMO_APPLY (proc, arg);
- else
- {
- SCM tail;
-
- rest = scm_reverse (rest);
- tail = scm_car (rest);
- rest = scm_cdr (rest);
- len--;
-
- while (scm_is_pair (rest))
- {
- tail = MAKMEMO_CALL (MAKMEMO_MOD_REF (scm_list_1 (scm_from_latin1_symbol ("guile")),
- scm_from_latin1_symbol ("cons"),
- SCM_BOOL_F),
- 2,
- scm_list_2 (scm_car (rest), tail));
- rest = scm_cdr (rest);
- }
- return MAKMEMO_APPLY (proc, tail);
- }
-}
-#undef FUNC_NAME
-
-static SCM m_call_cc (SCM proc)
-#define FUNC_NAME "@call-with-current-continuation"
-{
- SCM_VALIDATE_MEMOIZED (1, proc);
- return MAKMEMO_CONT (proc);
-}
-#undef FUNC_NAME
-
-static SCM m_call_values (SCM prod, SCM cons)
-#define FUNC_NAME "@call-with-values"
-{
- SCM_VALIDATE_MEMOIZED (1, prod);
- SCM_VALIDATE_MEMOIZED (2, cons);
- return MAKMEMO_CALL_WITH_VALUES (prod, cons);
-}
-#undef FUNC_NAME
-
-static SCM m_dynamic_wind (SCM in, SCM expr, SCM out)
-#define FUNC_NAME "memoize-dynwind"
-{
- SCM_VALIDATE_MEMOIZED (1, in);
- SCM_VALIDATE_MEMOIZED (2, expr);
- SCM_VALIDATE_MEMOIZED (3, out);
- return MAKMEMO_DYNWIND (in, expr, out);
-}
-#undef FUNC_NAME
-
-static SCM m_prompt (SCM tag, SCM exp, SCM handler)
-#define FUNC_NAME "@prompt"
-{
- SCM_VALIDATE_MEMOIZED (1, tag);
- SCM_VALIDATE_MEMOIZED (2, exp);
- SCM_VALIDATE_MEMOIZED (3, handler);
- return MAKMEMO_PROMPT (tag, exp, handler);
-}
-#undef FUNC_NAME
-
-
-\f
-
-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_utf8_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_SEQ:
- return scm_list_3 (scm_sym_begin, unmemoize (CAR (args)),
- unmemoize (CDR (args)));
- case SCM_M_CALL:
- 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:
- 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_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)));
- case SCM_M_LAMBDA:
- {
- SCM body = CAR (args), spec = CDDR (args);
-
- if (scm_is_null (CDR (spec)))
- return scm_list_3 (scm_sym_lambda,
- scm_make_list (CAR (spec), sym_placeholder),
- unmemoize (CAR (args)));
- else if (scm_is_null (SCM_CDDR (spec)))
- {
- SCM formals = scm_make_list (CAR (spec), sym_placeholder);
- return scm_list_3 (scm_sym_lambda,
- scm_is_true (CADR (spec))
- ? scm_cons_star (sym_placeholder, formals)
- : formals,
- unmemoize (CAR (args)));
- }
- else
- {
- SCM alt, tail;
-
- alt = CADDR (CDDDR (spec));
- if (scm_is_true (alt))
- tail = CDR (unmemoize (alt));
- else
- tail = SCM_EOL;
-
- return scm_cons
- (sym_case_lambda_star,
- scm_cons (scm_list_2 (scm_list_5 (CAR (spec),
- CADR (spec),
- CADDR (spec),
- CADDDR (spec),
- unmemoize_exprs (CADR (CDDDR (spec)))),
- unmemoize (body)),
- tail));
- }
- }
- 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_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_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)));
- case SCM_M_PROMPT:
- return scm_list_4 (scm_sym_at_prompt,
- unmemoize (CAR (args)),
- unmemoize (CADR (args)),
- unmemoize (CDDR (args)));
- default:
- abort ();
- }
-}
-
-
-\f
-
-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
-
-SCM_DEFINE (scm_memoized_expression_typecode, "memoized-expression-typecode", 1, 0, 0,
- (SCM m),
- "Return the typecode from the memoized expression @var{m}.")
-#define FUNC_NAME s_scm_memoized_expression_typecode
-{
- SCM_VALIDATE_MEMOIZED (1, m);
-
- /* The tag is a 16-bit integer so it fits in an inum. */
- return SCM_I_MAKINUM (SCM_MEMOIZED_TAG (m));
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_memoized_expression_data, "memoized-expression-data", 1, 0, 0,
- (SCM m),
- "Return the data from the memoized expression @var{m}.")
-#define FUNC_NAME s_scm_memoized_expression_data
-{
- SCM_VALIDATE_MEMOIZED (1, m);
- return SCM_MEMOIZED_ARGS (m);
-}
-#undef FUNC_NAME
-
-SCM_DEFINE (scm_memoized_typecode, "memoized-typecode", 1, 0, 0,
- (SCM sym),
- "Return the memoized typecode corresponding to the symbol @var{sym}.")
-#define FUNC_NAME s_scm_memoized_typecode
-{
- int i;
-
- SCM_VALIDATE_SYMBOL (1, sym);
-
- for (i = 0; i < sizeof(memoized_tags)/sizeof(const char*); i++)
- if (strcmp (scm_i_symbol_chars (sym), memoized_tags[i]) == 0)
- return scm_from_int32 (i);
-
- return SCM_BOOL_F;
-}
-#undef FUNC_NAME
-
-SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
-static void error_unbound_variable (SCM symbol) SCM_NORETURN;
-static void error_unbound_variable (SCM symbol)
-{
- scm_error (scm_unbound_variable_key, NULL, "Unbound variable: ~S",
- scm_list_1 (symbol), SCM_BOOL_F);
-}
-
-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_memoize_variable_access_x
-{
- SCM mx;
- SCM_VALIDATE_MEMOIZED (1, m);
- mx = SCM_MEMOIZED_ARGS (m);
- switch (SCM_MEMOIZED_TAG (m))
- {
- case SCM_M_TOPLEVEL_REF:
- if (SCM_VARIABLEP (mx))
- return mx;
- else
- {
- SCM var = scm_module_variable (mod, mx);
- if (scm_is_false (var) || scm_is_false (scm_variable_bound_p (var)))
- error_unbound_variable (mx);
- SCM_SET_SMOB_OBJECT (m, var);
- return var;
- }
-
- case SCM_M_TOPLEVEL_SET:
- {
- SCM var = CAR (mx);
- if (SCM_VARIABLEP (var))
- return var;
- else
- {
- var = scm_module_variable (mod, var);
- if (scm_is_false (var))
- error_unbound_variable (CAR (mx));
- SCM_SETCAR (mx, var);
- return var;
- }
- }
-
- case SCM_M_MODULE_REF:
- if (SCM_VARIABLEP (mx))
- return mx;
- else
- {
- SCM var;
- mod = scm_resolve_module (CAR (mx));
- if (scm_is_true (CDDR (mx)))
- mod = scm_module_public_interface (mod);
- var = scm_module_lookup (mod, CADR (mx));
- if (scm_is_false (scm_variable_bound_p (var)))
- error_unbound_variable (CADR (mx));
- SCM_SET_SMOB_OBJECT (m, var);
- return var;
- }
-
- case SCM_M_MODULE_SET:
- /* FIXME: not quite threadsafe */
- if (SCM_VARIABLEP (CDR (mx)))
- return CDR (mx);
- else
- {
- SCM var;
- mod = scm_resolve_module (CADR (mx));
- if (scm_is_true (CDDDR (mx)))
- mod = scm_module_public_interface (mod);
- var = scm_module_lookup (mod, CADDR (mx));
- SCM_SETCDR (mx, var);
- return var;
- }
-
- default:
- scm_wrong_type_arg (FUNC_NAME, 1, m);
- return SCM_BOOL_F;
- }
-}
-#undef FUNC_NAME
-
-
-\f
-
-void
-scm_init_memoize ()
-{
- scm_tc16_memoized = scm_make_smob_type ("%memoized", 0);
- scm_set_smob_print (scm_tc16_memoized, scm_print_memoized);
-
- scm_tc16_memoizer = scm_make_smob_type ("memoizer", 0);
-
-#include "libguile/memoize.x"
-
- list_of_guile = scm_list_1 (scm_from_latin1_symbol ("guile"));
-}
-
-/*
- Local Variables:
- c-file-style: "gnu"
- End:
-*/
+/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
+ * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014
+ * 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
+ */
+
+\f
+
+#ifdef HAVE_CONFIG_H
+# include <config.h>
+#endif
+
+#include "libguile/__scm.h"
+#include "libguile/_scm.h"
+#include "libguile/continuations.h"
+#include "libguile/eq.h"
+#include "libguile/expand.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"
+
+
+\f
+
+
+#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)
+
+#define VECTOR_REF(v, i) (SCM_SIMPLE_VECTOR_REF (v, i))
+#define VECTOR_SET(v, i, x) (SCM_SIMPLE_VECTOR_SET (v, i, x))
+#define VECTOR_LENGTH(v) (SCM_SIMPLE_VECTOR_LENGTH (v))
+
+SCM_SYMBOL (sym_case_lambda_star, "case-lambda*");
+
+\f
+
+
+/* Primitives not exposed to general Scheme. */
+static SCM wind;
+static SCM unwind;
+static SCM push_fluid;
+static SCM pop_fluid;
+
+static SCM
+do_wind (SCM in, SCM out)
+{
+ scm_dynstack_push_dynwind (&SCM_I_CURRENT_THREAD->dynstack, in, out);
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
+do_unwind (void)
+{
+ scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
+do_push_fluid (SCM fluid, SCM val)
+{
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+ scm_dynstack_push_fluid (&thread->dynstack, fluid, val,
+ thread->dynamic_state);
+ return SCM_UNSPECIFIED;
+}
+
+static SCM
+do_pop_fluid (void)
+{
+ scm_i_thread *thread = SCM_I_CURRENT_THREAD;
+ scm_dynstack_unwind_fluid (&thread->dynstack, thread->dynamic_state);
+ return SCM_UNSPECIFIED;
+}
+
+
+\f
+
+/* {Evaluator memoized expressions}
+ */
+
+scm_t_bits scm_tc16_memoized;
+
+#define MAKMEMO(n, args) \
+ (scm_cons (SCM_I_MAKINUM (n), args))
+
+#define MAKMEMO_SEQ(head,tail) \
+ MAKMEMO (SCM_M_SEQ, scm_cons (head, tail))
+#define MAKMEMO_IF(test, then, else_) \
+ MAKMEMO (SCM_M_IF, scm_cons (test, scm_cons (then, else_)))
+#define FIXED_ARITY(nreq) \
+ scm_list_1 (SCM_I_MAKINUM (nreq))
+#define REST_ARITY(nreq, rest) \
+ scm_list_2 (SCM_I_MAKINUM (nreq), rest)
+#define FULL_ARITY(nreq, rest, nopt, kw, ninits, unbound, alt) \
+ scm_list_n (SCM_I_MAKINUM (nreq), rest, SCM_I_MAKINUM (nopt), kw, \
+ SCM_I_MAKINUM (ninits), unbound, alt, SCM_UNDEFINED)
+#define MAKMEMO_LAMBDA(body, arity, meta) \
+ MAKMEMO (SCM_M_LAMBDA, \
+ scm_cons (body, scm_cons (meta, arity)))
+#define MAKMEMO_CAPTURE_ENV(vars, body) \
+ MAKMEMO (SCM_M_CAPTURE_ENV, scm_cons (vars, 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_CAPTURE_MODULE(exp) \
+ MAKMEMO (SCM_M_CAPTURE_MODULE, exp)
+#define MAKMEMO_APPLY(proc, args)\
+ MAKMEMO (SCM_M_APPLY, scm_list_2 (proc, args))
+#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, nargs, args) \
+ MAKMEMO (SCM_M_CALL, scm_cons (proc, scm_cons (SCM_I_MAKINUM (nargs), args)))
+#define MAKMEMO_LEX_REF(pos) \
+ MAKMEMO (SCM_M_LEXICAL_REF, pos)
+#define MAKMEMO_LEX_SET(pos, val) \
+ MAKMEMO (SCM_M_LEXICAL_SET, scm_cons (pos, val))
+#define MAKMEMO_BOX_REF(box) \
+ MAKMEMO (SCM_M_BOX_REF, box)
+#define MAKMEMO_BOX_SET(box, val) \
+ MAKMEMO (SCM_M_BOX_SET, scm_cons (box, val))
+#define MAKMEMO_TOP_BOX(mode, var) \
+ MAKMEMO (SCM_M_RESOLVE, scm_cons (SCM_I_MAKINUM (mode), var))
+#define MAKMEMO_MOD_BOX(mode, mod, var, public) \
+ MAKMEMO (SCM_M_RESOLVE, \
+ scm_cons (SCM_I_MAKINUM (mode), \
+ scm_cons (mod, scm_cons (var, public))))
+#define MAKMEMO_CALL_WITH_PROMPT(tag, thunk, handler) \
+ MAKMEMO (SCM_M_CALL_WITH_PROMPT, scm_cons (tag, scm_cons (thunk, handler)))
+
+
+\f
+
+/* This table must agree with the list of M_ constants in memoize.h */
+static const char *const memoized_tags[] =
+{
+ "seq",
+ "if",
+ "lambda",
+ "capture-env",
+ "let",
+ "quote",
+ "capture-module",
+ "apply",
+ "call/cc",
+ "call-with-values",
+ "call",
+ "lexical-ref",
+ "lexical-set!",
+ "box-ref",
+ "box-set!",
+ "resolve",
+ "call-with-prompt",
+};
+
+
+\f
+
+
+/* Memoization-time environments mirror the structure of eval-time
+ environments. Each link in the chain at memoization-time corresponds
+ to a link at eval-time.
+
+ env := module | (link, env)
+ module := #f | #t
+ link := flat-link . nested-link
+ flat-link := (#t . ((var . pos) ...))
+ nested-link := (#f . #(var ...))
+
+ A module of #f indicates that the current module has not yet been
+ captured. Memoizing a capture-module expression will capture the
+ module.
+
+ Flat environments copy the values for a set of free variables into a
+ flat environment, via the capture-env expression. During memoization
+ a flat link collects the values of free variables, along with their
+ resolved outer locations. We are able to copy values because the
+ incoming expression has already been assignment-converted. Flat
+ environments prevent closures from hanging on to too much memory.
+
+ Nested environments have a rib of "let" bindings, and link to an
+ outer environment.
+*/
+
+static int
+try_lookup_rib (SCM x, SCM rib)
+{
+ int idx = 0;
+ for (; idx < VECTOR_LENGTH (rib); idx++)
+ if (scm_is_eq (x, VECTOR_REF (rib, idx)))
+ return idx; /* bound */
+ return -1;
+}
+
+static int
+lookup_rib (SCM x, SCM rib)
+{
+ int idx = try_lookup_rib (x, rib);
+ if (idx < 0)
+ abort ();
+ return idx;
+}
+
+static SCM
+make_pos (int depth, int width)
+{
+ return scm_cons (SCM_I_MAKINUM (depth), SCM_I_MAKINUM (width));
+}
+
+static SCM
+push_nested_link (SCM vars, SCM env)
+{
+ return scm_acons (SCM_BOOL_F, vars, env);
+}
+
+static SCM
+push_flat_link (SCM env)
+{
+ return scm_acons (SCM_BOOL_T, SCM_EOL, env);
+}
+
+static int
+env_link_is_flat (SCM env_link)
+{
+ return scm_is_true (CAR (env_link));
+}
+
+static SCM
+env_link_vars (SCM env_link)
+{
+ return CDR (env_link);
+}
+
+static void
+env_link_add_flat_var (SCM env_link, SCM var, SCM pos)
+{
+ SCM vars = env_link_vars (env_link);
+ if (scm_is_false (scm_assq (var, vars)))
+ scm_set_cdr_x (env_link, scm_acons (var, pos, vars));
+}
+
+static SCM
+lookup (SCM x, SCM env)
+{
+ int d = 0;
+ for (; scm_is_pair (env); env = CDR (env), d++)
+ {
+ SCM link = CAR (env);
+ if (env_link_is_flat (link))
+ {
+ int w;
+ SCM vars;
+
+ for (vars = env_link_vars (link), w = scm_ilength (vars) - 1;
+ scm_is_pair (vars);
+ vars = CDR (vars), w--)
+ if (scm_is_eq (x, (CAAR (vars))))
+ return make_pos (d, w);
+
+ env_link_add_flat_var (link, x, lookup (x, CDR (env)));
+ return make_pos (d, scm_ilength (env_link_vars (link)) - 1);
+ }
+ else
+ {
+ int w = try_lookup_rib (x, env_link_vars (link));
+ if (w < 0)
+ continue;
+ return make_pos (d, w);
+ }
+ }
+ abort ();
+}
+
+static SCM
+capture_flat_env (SCM lambda, SCM env)
+{
+ int nenv;
+ SCM vars, link, locs;
+
+ link = CAR (env);
+ vars = env_link_vars (link);
+ nenv = scm_ilength (vars);
+ locs = scm_c_make_vector (nenv, SCM_BOOL_F);
+
+ for (; scm_is_pair (vars); vars = CDR (vars))
+ scm_c_vector_set_x (locs, --nenv, CDAR (vars));
+
+ return MAKMEMO_CAPTURE_ENV (locs, lambda);
+}
+
+/* Abbreviate SCM_EXPANDED_REF. Copied because I'm not sure about symbol pasting */
+#define REF(x,type,field) \
+ (scm_struct_ref (x, SCM_I_MAKINUM (SCM_EXPANDED_##type##_##field)))
+
+static SCM list_of_guile = SCM_BOOL_F;
+
+static SCM memoize (SCM exp, SCM env);
+
+static SCM
+memoize_exps (SCM exps, SCM env)
+{
+ SCM ret;
+ for (ret = SCM_EOL; scm_is_pair (exps); exps = CDR (exps))
+ ret = scm_cons (memoize (CAR (exps), env), ret);
+ return scm_reverse_x (ret, SCM_UNDEFINED);
+}
+
+static SCM
+capture_env (SCM env)
+{
+ if (scm_is_false (env))
+ return SCM_BOOL_T;
+ return env;
+}
+
+static SCM
+maybe_makmemo_capture_module (SCM exp, SCM env)
+{
+ if (scm_is_false (env))
+ return MAKMEMO_CAPTURE_MODULE (exp);
+ return exp;
+}
+
+static SCM
+memoize (SCM exp, SCM env)
+{
+ if (!SCM_EXPANDED_P (exp))
+ abort ();
+
+ switch (SCM_EXPANDED_TYPE (exp))
+ {
+ case SCM_EXPANDED_VOID:
+ return MAKMEMO_QUOTE (SCM_UNSPECIFIED);
+
+ case SCM_EXPANDED_CONST:
+ return MAKMEMO_QUOTE (REF (exp, CONST, EXP));
+
+ case SCM_EXPANDED_PRIMITIVE_REF:
+ if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
+ return maybe_makmemo_capture_module
+ (MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
+ REF (exp, PRIMITIVE_REF, NAME))),
+ env);
+ else
+ return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF,
+ list_of_guile,
+ REF (exp, PRIMITIVE_REF, NAME),
+ SCM_BOOL_F));
+
+ case SCM_EXPANDED_LEXICAL_REF:
+ return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env));
+
+ case SCM_EXPANDED_LEXICAL_SET:
+ return MAKMEMO_LEX_SET (lookup (REF (exp, LEXICAL_SET, GENSYM), env),
+ memoize (REF (exp, LEXICAL_SET, EXP), env));
+
+ case SCM_EXPANDED_MODULE_REF:
+ return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX
+ (SCM_EXPANDED_MODULE_REF,
+ REF (exp, MODULE_REF, MOD),
+ REF (exp, MODULE_REF, NAME),
+ REF (exp, MODULE_REF, PUBLIC)));
+
+ case SCM_EXPANDED_MODULE_SET:
+ return MAKMEMO_BOX_SET (MAKMEMO_MOD_BOX
+ (SCM_EXPANDED_MODULE_SET,
+ REF (exp, MODULE_SET, MOD),
+ REF (exp, MODULE_SET, NAME),
+ REF (exp, MODULE_SET, PUBLIC)),
+ memoize (REF (exp, MODULE_SET, EXP), env));
+
+ case SCM_EXPANDED_TOPLEVEL_REF:
+ return maybe_makmemo_capture_module
+ (MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
+ REF (exp, TOPLEVEL_REF, NAME))),
+ env);
+
+ case SCM_EXPANDED_TOPLEVEL_SET:
+ return maybe_makmemo_capture_module
+ (MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_SET,
+ REF (exp, TOPLEVEL_SET, NAME)),
+ memoize (REF (exp, TOPLEVEL_SET, EXP),
+ capture_env (env))),
+ env);
+
+ case SCM_EXPANDED_TOPLEVEL_DEFINE:
+ return maybe_makmemo_capture_module
+ (MAKMEMO_BOX_SET (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_DEFINE,
+ REF (exp, TOPLEVEL_DEFINE, NAME)),
+ memoize (REF (exp, TOPLEVEL_DEFINE, EXP),
+ capture_env (env))),
+ env);
+
+ case SCM_EXPANDED_CONDITIONAL:
+ return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env),
+ memoize (REF (exp, CONDITIONAL, CONSEQUENT), env),
+ memoize (REF (exp, CONDITIONAL, ALTERNATE), env));
+
+ case SCM_EXPANDED_CALL:
+ {
+ SCM proc, args;
+
+ proc = REF (exp, CALL, PROC);
+ args = memoize_exps (REF (exp, CALL, ARGS), env);
+
+ return MAKMEMO_CALL (memoize (proc, env), scm_ilength (args), args);
+ }
+
+ case SCM_EXPANDED_PRIMCALL:
+ {
+ SCM name, args;
+ int nargs;
+
+ name = REF (exp, PRIMCALL, NAME);
+ args = memoize_exps (REF (exp, PRIMCALL, ARGS), env);
+ nargs = scm_ilength (args);
+
+ if (nargs == 3
+ && scm_is_eq (name, scm_from_latin1_symbol ("call-with-prompt")))
+ return MAKMEMO_CALL_WITH_PROMPT (CAR (args),
+ CADR (args),
+ CADDR (args));
+ else if (nargs == 2
+ && scm_is_eq (name, scm_from_latin1_symbol ("apply")))
+ return MAKMEMO_APPLY (CAR (args), CADR (args));
+ else if (nargs == 1
+ && scm_is_eq (name,
+ scm_from_latin1_symbol
+ ("call-with-current-continuation")))
+ return MAKMEMO_CONT (CAR (args));
+ else if (nargs == 2
+ && scm_is_eq (name,
+ scm_from_latin1_symbol ("call-with-values")))
+ return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args));
+ else if (nargs == 1
+ && scm_is_eq (name,
+ scm_from_latin1_symbol ("variable-ref")))
+ return MAKMEMO_BOX_REF (CAR (args));
+ else if (nargs == 2
+ && scm_is_eq (name,
+ scm_from_latin1_symbol ("variable-set!")))
+ return MAKMEMO_BOX_SET (CAR (args), CADR (args));
+ else if (nargs == 2
+ && scm_is_eq (name, scm_from_latin1_symbol ("wind")))
+ return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), 2, args);
+ else if (nargs == 0
+ && scm_is_eq (name, scm_from_latin1_symbol ("unwind")))
+ return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), 0, SCM_EOL);
+ else if (nargs == 2
+ && scm_is_eq (name, scm_from_latin1_symbol ("push-fluid")))
+ return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), 2, args);
+ else if (nargs == 0
+ && scm_is_eq (name, scm_from_latin1_symbol ("pop-fluid")))
+ return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), 0, SCM_EOL);
+ else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
+ return MAKMEMO_CALL (maybe_makmemo_capture_module
+ (MAKMEMO_BOX_REF
+ (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
+ name)),
+ env),
+ nargs, args);
+ else
+ return MAKMEMO_CALL (MAKMEMO_BOX_REF
+ (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF,
+ list_of_guile,
+ name,
+ SCM_BOOL_F)),
+ nargs,
+ args);
+ }
+
+ case SCM_EXPANDED_SEQ:
+ return MAKMEMO_SEQ (memoize (REF (exp, SEQ, HEAD), env),
+ memoize (REF (exp, SEQ, TAIL), env));
+
+ case SCM_EXPANDED_LAMBDA:
+ /* The body will be a lambda-case. */
+ {
+ SCM meta, body, proc, new_env;
+
+ meta = REF (exp, LAMBDA, META);
+ body = REF (exp, LAMBDA, BODY);
+ new_env = push_flat_link (capture_env (env));
+ proc = memoize (body, new_env);
+ SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta);
+
+ return maybe_makmemo_capture_module (capture_flat_env (proc, new_env),
+ env);
+ }
+
+ case SCM_EXPANDED_LAMBDA_CASE:
+ {
+ SCM req, rest, opt, kw, inits, vars, body, alt;
+ SCM unbound, arity, rib, new_env;
+ int nreq, nopt, ninits;
+
+ req = REF (exp, LAMBDA_CASE, REQ);
+ rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST)));
+ opt = REF (exp, LAMBDA_CASE, OPT);
+ kw = REF (exp, LAMBDA_CASE, KW);
+ inits = REF (exp, LAMBDA_CASE, INITS);
+ vars = REF (exp, LAMBDA_CASE, GENSYMS);
+ body = REF (exp, LAMBDA_CASE, BODY);
+ alt = REF (exp, LAMBDA_CASE, ALTERNATE);
+
+ nreq = scm_ilength (req);
+ nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0;
+ ninits = scm_ilength (inits);
+ /* This relies on assignment conversion turning inits into a
+ sequence of CONST expressions whose values are a unique
+ "unbound" token. */
+ unbound = ninits ? REF (CAR (inits), CONST, EXP) : SCM_BOOL_F;
+ rib = scm_vector (vars);
+ new_env = push_nested_link (rib, env);
+
+ if (scm_is_true (kw))
+ {
+ /* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */
+ SCM aok = CAR (kw), indices = SCM_EOL;
+ for (kw = CDR (kw); scm_is_pair (kw); kw = CDR (kw))
+ {
+ SCM k;
+ int idx;
+
+ k = CAR (CAR (kw));
+ idx = lookup_rib (CADDR (CAR (kw)), rib);
+ indices = scm_acons (k, SCM_I_MAKINUM (idx), indices);
+ }
+ kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED));
+ }
+
+ if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt))
+ {
+ if (scm_is_false (rest))
+ arity = FIXED_ARITY (nreq);
+ else
+ arity = REST_ARITY (nreq, SCM_BOOL_T);
+ }
+ else if (scm_is_true (alt))
+ arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
+ SCM_MEMOIZED_ARGS (memoize (alt, env)));
+ else
+ arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
+ SCM_BOOL_F);
+
+ return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
+ SCM_EOL /* meta, filled in later */);
+ }
+
+ case SCM_EXPANDED_LET:
+ {
+ SCM vars, exps, body, varsv, inits, new_env;
+ int i;
+
+ vars = REF (exp, LET, GENSYMS);
+ exps = REF (exp, LET, VALS);
+ body = REF (exp, LET, BODY);
+
+ varsv = scm_vector (vars);
+ inits = scm_c_make_vector (VECTOR_LENGTH (varsv),
+ SCM_BOOL_F);
+ new_env = push_nested_link (varsv, capture_env (env));
+ for (i = 0; scm_is_pair (exps); exps = CDR (exps), i++)
+ VECTOR_SET (inits, i, memoize (CAR (exps), env));
+
+ return maybe_makmemo_capture_module
+ (MAKMEMO_LET (inits, memoize (body, new_env)), env);
+ }
+
+ default:
+ abort ();
+ }
+}
+
+
+\f
+
+SCM_DEFINE (scm_memoize_expression, "memoize-expression", 1, 0, 0,
+ (SCM exp),
+ "Memoize the expression @var{exp}.")
+#define FUNC_NAME s_scm_memoize_expression
+{
+ SCM_ASSERT_TYPE (SCM_EXPANDED_P (exp), exp, 1, FUNC_NAME, "expanded");
+ return memoize (scm_convert_assignment (exp), SCM_BOOL_F);
+}
+#undef FUNC_NAME
+
+
+\f
+
+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 = SCM_EOL;
+ int n = scm_c_vector_length (inits);
+
+ while (n--)
+ ret = scm_cons (unmemoize (scm_c_vector_ref (inits, n)), ret);
+
+ return ret;
+}
+
+static SCM
+unmemoize_lexical (SCM n)
+{
+ char buf[32];
+ buf[31] = 0;
+ snprintf (buf, 31, "<%u,%u>", scm_to_uint32 (CAR (n)),
+ scm_to_uint32 (CDR (n)));
+ return scm_from_utf8_symbol (buf);
+}
+
+static SCM
+unmemoize (const SCM expr)
+{
+ SCM args;
+
+ args = SCM_MEMOIZED_ARGS (expr);
+ switch (SCM_MEMOIZED_TAG (expr))
+ {
+ case SCM_M_APPLY:
+ return scm_cons (scm_from_latin1_symbol ("apply"),
+ unmemoize_exprs (args));
+ case SCM_M_SEQ:
+ return scm_list_3 (scm_sym_begin, unmemoize (CAR (args)),
+ unmemoize (CDR (args)));
+ case SCM_M_CALL:
+ return scm_cons (unmemoize (CAR (args)), unmemoize_exprs (CDDR (args)));
+ case SCM_M_CONT:
+ return scm_list_2 (scm_from_latin1_symbol
+ ("call-with-current_continuation"),
+ unmemoize (args));
+ case SCM_M_CALL_WITH_VALUES:
+ return scm_list_3 (scm_from_latin1_symbol ("call-with-values"),
+ unmemoize (CAR (args)), unmemoize (CDR (args)));
+ case SCM_M_CAPTURE_MODULE:
+ return scm_list_2 (scm_from_latin1_symbol ("capture-module"),
+ unmemoize (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:
+ {
+ SCM body = CAR (args), spec = CDDR (args);
+
+ if (scm_is_null (CDR (spec)))
+ return scm_list_3 (scm_sym_lambda,
+ scm_make_list (CAR (spec), sym_placeholder),
+ unmemoize (CAR (args)));
+ else if (scm_is_null (SCM_CDDR (spec)))
+ {
+ SCM formals = scm_make_list (CAR (spec), sym_placeholder);
+ return scm_list_3 (scm_sym_lambda,
+ scm_is_true (CADR (spec))
+ ? scm_cons_star (sym_placeholder, formals)
+ : formals,
+ unmemoize (CAR (args)));
+ }
+ else
+ {
+ SCM alt, tail;
+
+ alt = CADDDR (CDDDR (spec));
+ if (scm_is_true (alt))
+ tail = CDR (unmemoize (alt));
+ else
+ tail = SCM_EOL;
+
+ return scm_cons
+ (sym_case_lambda_star,
+ scm_cons (scm_list_2 (scm_list_5 (CAR (spec),
+ CADR (spec),
+ CADDR (spec),
+ CADDDR (spec),
+ CADR (CDDDR (spec))),
+ unmemoize (body)),
+ tail));
+ }
+ }
+ case SCM_M_CAPTURE_ENV:
+ return scm_list_3 (scm_from_latin1_symbol ("capture-env"),
+ CAR (args),
+ unmemoize (CDR (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_BOX_REF:
+ return scm_list_2 (scm_from_latin1_symbol ("variable-ref"),
+ unmemoize (args));
+ case SCM_M_BOX_SET:
+ return scm_list_3 (scm_from_latin1_symbol ("variable-set!"),
+ unmemoize (CAR (args)),
+ unmemoize (CDR (args)));
+ case SCM_M_RESOLVE:
+ if (SCM_VARIABLEP (args))
+ return args;
+ else if (scm_is_symbol (CDR (args)))
+ return CDR (args);
+ else
+ return scm_list_3
+ (scm_is_true (CDDDR (args)) ? scm_sym_at : scm_sym_atat,
+ scm_i_finite_list_copy (CADR (args)),
+ CADDR (args));
+ case SCM_M_CALL_WITH_PROMPT:
+ return scm_list_4 (scm_from_latin1_symbol ("call-with-prompt"),
+ unmemoize (CAR (args)),
+ unmemoize (CADR (args)),
+ unmemoize (CDDR (args)));
+ default:
+ abort ();
+ }
+}
+
+
+\f
+
+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
+{
+ return unmemoize (m);
+}
+#undef FUNC_NAME
+
+SCM_DEFINE (scm_memoized_typecode, "memoized-typecode", 1, 0, 0,
+ (SCM sym),
+ "Return the memoized typecode corresponding to the symbol @var{sym}.")
+#define FUNC_NAME s_scm_memoized_typecode
+{
+ int i;
+
+ SCM_VALIDATE_SYMBOL (1, sym);
+
+ for (i = 0; i < sizeof(memoized_tags)/sizeof(const char*); i++)
+ if (strcmp (scm_i_symbol_chars (sym), memoized_tags[i]) == 0)
+ return scm_from_int32 (i);
+
+ return SCM_BOOL_F;
+}
+#undef FUNC_NAME
+
+SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
+static void error_unbound_variable (SCM symbol) SCM_NORETURN;
+static void error_unbound_variable (SCM symbol)
+{
+ scm_error (scm_unbound_variable_key, NULL, "Unbound variable: ~S",
+ scm_list_1 (symbol), SCM_BOOL_F);
+}
+
+SCM_DEFINE (scm_sys_resolve_variable, "%resolve-variable", 2, 0, 0,
+ (SCM loc, SCM mod),
+ "Look up and return the variable for @var{loc}.")
+#define FUNC_NAME s_scm_sys_resolve_variable
+{
+ int mode;
+
+ if (scm_is_false (mod))
+ mod = scm_the_root_module ();
+
+ mode = scm_to_int (scm_car (loc));
+ loc = scm_cdr (loc);
+
+ switch (mode)
+ {
+ case SCM_EXPANDED_TOPLEVEL_REF:
+ case SCM_EXPANDED_TOPLEVEL_SET:
+ {
+ SCM var = scm_module_variable (mod, loc);
+ if (scm_is_false (var)
+ || (mode == SCM_EXPANDED_TOPLEVEL_REF
+ && scm_is_false (scm_variable_bound_p (var))))
+ error_unbound_variable (loc);
+ return var;
+ }
+
+ case SCM_EXPANDED_TOPLEVEL_DEFINE:
+ {
+ return scm_module_ensure_local_variable (mod, loc);
+ }
+
+ case SCM_EXPANDED_MODULE_REF:
+ case SCM_EXPANDED_MODULE_SET:
+ {
+ SCM var;
+ mod = scm_resolve_module (scm_car (loc));
+ if (scm_is_true (scm_cddr (loc)))
+ mod = scm_module_public_interface (mod);
+ var = scm_module_lookup (mod, scm_cadr (loc));
+ if (mode == SCM_EXPANDED_MODULE_SET
+ && scm_is_false (scm_variable_bound_p (var)))
+ error_unbound_variable (scm_cadr (loc));
+ return var;
+ }
+
+ default:
+ scm_wrong_type_arg (FUNC_NAME, 1, loc);
+ return SCM_BOOL_F;
+ }
+}
+#undef FUNC_NAME
+
+
+\f
+
+void
+scm_init_memoize ()
+{
+#include "libguile/memoize.x"
+
+ wind = scm_c_make_gsubr ("wind", 2, 0, 0, do_wind);
+ unwind = scm_c_make_gsubr ("unwind", 0, 0, 0, do_unwind);
+ push_fluid = scm_c_make_gsubr ("push-fluid", 2, 0, 0, do_push_fluid);
+ pop_fluid = scm_c_make_gsubr ("pop-fluid", 0, 0, 0, do_pop_fluid);
+
+ list_of_guile = scm_list_1 (scm_from_latin1_symbol ("guile"));
+}
+
+/*
+ Local Variables:
+ c-file-style: "gnu"
+ End:
+*/
HCoop / bpt / guile.git / blobdiff