scm_t_bits scm_tc16_memoized;
#define MAKMEMO(n, args) \
- (scm_cell (scm_tc16_memoized | ((n) << 16), SCM_UNPACK (args)))
+ (scm_cons (SCM_I_MAKINUM (n), args))
#define MAKMEMO_SEQ(head,tail) \
MAKMEMO (SCM_M_SEQ, scm_cons (head, tail))
#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) \
+#define MAKMEMO_LAMBDA(body, arity, meta) \
MAKMEMO (SCM_M_LAMBDA, \
- scm_cons (body, scm_cons (docstring, arity)))
+ scm_cons (body, scm_cons (meta, 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_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) \
"let",
"quote",
"define",
+ "capture-module",
"apply",
"call/cc",
"call-with-values",
"call-with-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
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)
{
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));
+ return maybe_makmemo_capture_module
+ (MAKMEMO_TOP_REF (REF (exp, PRIMITIVE_REF, NAME)),
+ env);
else
return MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMITIVE_REF, NAME),
SCM_BOOL_F);
REF (exp, MODULE_SET, PUBLIC));
case SCM_EXPANDED_TOPLEVEL_REF:
- return MAKMEMO_TOP_REF (REF (exp, TOPLEVEL_REF, NAME));
+ return maybe_makmemo_capture_module
+ (MAKMEMO_TOP_REF (REF (exp, TOPLEVEL_REF, NAME)), env);
case SCM_EXPANDED_TOPLEVEL_SET:
- return MAKMEMO_TOP_SET (REF (exp, TOPLEVEL_SET, NAME),
- memoize (REF (exp, TOPLEVEL_SET, EXP), env));
+ return maybe_makmemo_capture_module
+ (MAKMEMO_TOP_SET (REF (exp, TOPLEVEL_SET, NAME),
+ memoize (REF (exp, TOPLEVEL_SET, EXP),
+ capture_env (env))),
+ env);
case SCM_EXPANDED_TOPLEVEL_DEFINE:
return MAKMEMO_DEFINE (REF (exp, TOPLEVEL_DEFINE, NAME),
&& 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 (MAKMEMO_TOP_REF (name), nargs, args);
+ return MAKMEMO_CALL (maybe_makmemo_capture_module
+ (MAKMEMO_TOP_REF (name), env),
+ nargs, args);
else
return MAKMEMO_CALL (MAKMEMO_MOD_REF (list_of_guile, name,
SCM_BOOL_F),
case SCM_EXPANDED_LAMBDA:
/* The body will be a lambda-case or #f. */
{
- SCM meta, docstring, body, proc;
+ SCM meta, 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))
MAKMEMO_QUOTE (SCM_EOL),
MAKMEMO_QUOTE (SCM_BOOL_F))),
FIXED_ARITY (0),
- SCM_BOOL_F /* docstring */);
+ meta);
else
- proc = memoize (body, env);
-
- if (scm_is_string (docstring))
- {
- SCM args = SCM_MEMOIZED_ARGS (proc);
- SCM_SETCAR (SCM_CDR (args), docstring);
- }
+ {
+ proc = memoize (body, capture_env (env));
+ SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta);
+ }
- return proc;
+ return maybe_makmemo_capture_module (proc, env);
}
case SCM_EXPANDED_LAMBDA_CASE:
arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F);
return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
- SCM_BOOL_F /* docstring */);
+ SCM_BOOL_F /* meta, filled in later */);
}
case SCM_EXPANDED_LET:
varsv = scm_vector (vars);
inits = scm_c_make_vector (VECTOR_LENGTH (varsv),
SCM_BOOL_F);
- new_env = scm_cons (varsv, env);
+ new_env = scm_cons (varsv, capture_env (env));
for (i = 0; scm_is_pair (exps); exps = CDR (exps), i++)
VECTOR_SET (inits, i, memoize (CAR (exps), env));
- return MAKMEMO_LET (inits, memoize (body, new_env));
+ return maybe_makmemo_capture_module
+ (MAKMEMO_LET (inits, memoize (body, new_env)), env);
}
case SCM_EXPANDED_LETREC:
expsv = scm_vector (exps);
undefs = scm_c_make_vector (nvars, MAKMEMO_QUOTE (SCM_UNDEFINED));
- new_env = scm_cons (varsv, env);
+ new_env = scm_cons (varsv, capture_env (env));
if (in_order_p)
{
body_exps = MAKMEMO_SEQ (MAKMEMO_LEX_SET (make_pos (0, i), init),
body_exps);
}
- return MAKMEMO_LET (undefs, body_exps);
+ return maybe_makmemo_capture_module
+ (MAKMEMO_LET (undefs, body_exps), env);
}
else
{
if (scm_is_false (sets))
return memoize (body, env);
- return MAKMEMO_LET (undefs,
- MAKMEMO_SEQ (MAKMEMO_LET (inits, sets),
- memoize (body, new_env)));
+ return maybe_makmemo_capture_module
+ (MAKMEMO_LET (undefs,
+ MAKMEMO_SEQ (MAKMEMO_LET (inits, sets),
+ memoize (body, new_env))),
+ env);
}
}
#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 ());
+ return memoize (exp, SCM_BOOL_F);
}
#undef FUNC_NAME
{
SCM args;
- if (!SCM_MEMOIZED_P (expr))
- abort ();
-
args = SCM_MEMOIZED_ARGS (expr);
switch (SCM_MEMOIZED_TAG (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_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)));
\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}.")
"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);
+ SCM mx = SCM_MEMOIZED_ARGS (m);
+
+ if (scm_is_false (mod))
+ mod = scm_the_root_module ();
+
switch (SCM_MEMOIZED_TAG (m))
{
case SCM_M_TOPLEVEL_REF:
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);
+ SCM_SETCDR (m, var);
return var;
}
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);
+ SCM_SETCDR (m, var);
return var;
}
void
scm_init_memoize ()
{
- scm_tc16_memoized = scm_make_smob_type ("%memoized", 0);
- scm_set_smob_print (scm_tc16_memoized, scm_print_memoized);
-
#include "libguile/memoize.x"
wind = scm_c_make_gsubr ("wind", 2, 0, 0, do_wind);
HCoop / bpt / guile.git / blobdiff