/* Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003,
- * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013
+ * 2004, 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
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 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_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_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_CALL(proc, args) \
+ MAKMEMO (SCM_M_CALL, scm_cons (proc, 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_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_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)))
"seq",
"if",
"lambda",
+ "capture-env",
"let",
"quote",
- "define",
"capture-module",
"apply",
"call/cc",
"call",
"lexical-ref",
"lexical-set!",
- "toplevel-ref",
- "toplevel-set!",
- "module-ref",
- "module-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)
{
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++)
{
- int w = try_lookup_rib (x, CAR (env));
- if (w < 0)
- continue;
- return make_pos (d, w);
+ 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)))
case SCM_EXPANDED_PRIMITIVE_REF:
if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
return maybe_makmemo_capture_module
- (MAKMEMO_TOP_REF (REF (exp, PRIMITIVE_REF, NAME)),
+ (MAKMEMO_BOX_REF (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
+ REF (exp, PRIMITIVE_REF, NAME))),
env);
else
- return MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMITIVE_REF, NAME),
- SCM_BOOL_F);
+ 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));
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));
+ 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_MOD_SET (memoize (REF (exp, MODULE_SET, EXP), env),
- REF (exp, MODULE_SET, MOD),
- REF (exp, MODULE_SET, NAME),
- REF (exp, MODULE_SET, PUBLIC));
+ 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_TOP_REF (REF (exp, TOPLEVEL_REF, NAME)), env);
+ (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_TOP_SET (REF (exp, TOPLEVEL_SET, NAME),
+ (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 MAKMEMO_DEFINE (REF (exp, TOPLEVEL_DEFINE, NAME),
- memoize (REF (exp, TOPLEVEL_DEFINE, EXP), env));
+ 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),
proc = REF (exp, CALL, PROC);
args = memoize_exps (REF (exp, CALL, ARGS), env);
- return MAKMEMO_CALL (memoize (proc, env), scm_ilength (args), args);
+ return MAKMEMO_CALL (memoize (proc, env), args);
}
case SCM_EXPANDED_PRIMCALL:
&& 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);
+ return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), args);
else if (nargs == 0
&& scm_is_eq (name, scm_from_latin1_symbol ("unwind")))
- return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), 0, SCM_EOL);
+ return MAKMEMO_CALL (MAKMEMO_QUOTE (unwind), 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);
+ return MAKMEMO_CALL (MAKMEMO_QUOTE (push_fluid), 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);
+ return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), SCM_EOL);
else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
return MAKMEMO_CALL (maybe_makmemo_capture_module
- (MAKMEMO_TOP_REF (name), env),
- nargs, args);
+ (MAKMEMO_BOX_REF
+ (MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
+ name)),
+ env),
+ args);
else
- return MAKMEMO_CALL (MAKMEMO_MOD_REF (list_of_guile, name,
- SCM_BOOL_F),
- nargs,
+ return MAKMEMO_CALL (MAKMEMO_BOX_REF
+ (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF,
+ list_of_guile,
+ name,
+ SCM_BOOL_F)),
args);
}
memoize (REF (exp, SEQ, TAIL), env));
case SCM_EXPANDED_LAMBDA:
- /* The body will be a lambda-case or #f. */
+ /* The body will be a lambda-case. */
{
- SCM meta, body, proc;
+ SCM meta, body, proc, new_env;
meta = REF (exp, LAMBDA, META);
-
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),
- meta);
- else
- {
- proc = memoize (body, capture_env (env));
- SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta);
- }
+ 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 (proc, env);
+ 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 walk, minits, arity, rib, new_env;
- int nreq, nopt;
+ 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)));
nreq = scm_ilength (req);
nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0;
-
- /* The vars are the gensyms, according to the divine plan. But we need
- to memoize the inits within their appropriate environment,
- complicating things. */
+ 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 = scm_cons (rib, env);
-
- minits = SCM_EOL;
- for (walk = inits; scm_is_pair (walk); walk = CDR (walk))
- minits = scm_cons (memoize (CAR (walk), new_env), minits);
- minits = scm_reverse_x (minits, SCM_UNDEFINED);
+ new_env = push_nested_link (rib, env);
if (scm_is_true (kw))
{
arity = REST_ARITY (nreq, SCM_BOOL_T);
}
else if (scm_is_true (alt))
- arity = FULL_ARITY (nreq, rest, nopt, kw, minits,
+ arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
SCM_MEMOIZED_ARGS (memoize (alt, env)));
else
- arity = FULL_ARITY (nreq, rest, nopt, kw, minits, SCM_BOOL_F);
+ arity = FULL_ARITY (nreq, rest, nopt, kw, ninits, unbound,
+ SCM_BOOL_F);
return MAKMEMO_LAMBDA (memoize (body, new_env), arity,
- SCM_BOOL_F /* meta, filled in later */);
+ SCM_EOL /* 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, capture_env (env));
+ 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));
(MAKMEMO_LET (inits, memoize (body, new_env)), env);
}
- case SCM_EXPANDED_LETREC:
- {
- SCM vars, varsv, exps, expsv, 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));
-
- varsv = scm_vector (vars);
- nvars = VECTOR_LENGTH (varsv);
- expsv = scm_vector (exps);
-
- undefs = scm_c_make_vector (nvars, MAKMEMO_QUOTE (SCM_UNDEFINED));
- new_env = scm_cons (varsv, capture_env (env));
-
- if (in_order_p)
- {
- SCM body_exps = memoize (body, new_env);
- for (i = nvars - 1; i >= 0; i--)
- {
- SCM init = memoize (VECTOR_REF (expsv, i), new_env);
- body_exps = MAKMEMO_SEQ (MAKMEMO_LEX_SET (make_pos (0, i), init),
- body_exps);
- }
- return maybe_makmemo_capture_module
- (MAKMEMO_LET (undefs, body_exps), env);
- }
- else
- {
- SCM sets = SCM_BOOL_F, inits = scm_c_make_vector (nvars, SCM_BOOL_F);
- for (i = nvars - 1; i >= 0; i--)
- {
- SCM init, set;
-
- init = memoize (VECTOR_REF (expsv, i), new_env);
- VECTOR_SET (inits, i, init);
-
- set = MAKMEMO_LEX_SET (make_pos (1, i),
- MAKMEMO_LEX_REF (make_pos (0, i)));
- if (scm_is_false (sets))
- sets = set;
- else
- sets = MAKMEMO_SEQ (set, sets);
- }
-
- if (scm_is_false (sets))
- return memoize (body, env);
-
- return maybe_makmemo_capture_module
- (MAKMEMO_LET (undefs,
- MAKMEMO_SEQ (MAKMEMO_LET (inits, sets),
- memoize (body, new_env))),
- env);
- }
- }
-
default:
abort ();
}
#define FUNC_NAME s_scm_memoize_expression
{
SCM_ASSERT_TYPE (SCM_EXPANDED_P (exp), exp, 1, FUNC_NAME, "expanded");
- return memoize (exp, SCM_BOOL_F);
+ return memoize (scm_convert_assignment (exp), SCM_BOOL_F);
}
#undef FUNC_NAME
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)));
+ return unmemoize_exprs (args);
case SCM_M_CONT:
return scm_list_2 (scm_from_latin1_symbol
("call-with-current_continuation"),
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_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));
{
SCM alt, tail;
- alt = CADDR (CDDDR (spec));
+ alt = CADDDR (CDDDR (spec));
if (scm_is_true (alt))
tail = CDR (unmemoize (alt));
else
CADR (spec),
CADDR (spec),
CADDDR (spec),
- unmemoize_exprs (CADR (CDDDR (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)),
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_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)),
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_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
{
- SCM mx = SCM_MEMOIZED_ARGS (m);
+ int mode;
if (scm_is_false (mod))
mod = scm_the_root_module ();
- 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_SETCDR (m, var);
- return var;
- }
+ mode = scm_to_int (scm_car (loc));
+ loc = scm_cdr (loc);
- case SCM_M_TOPLEVEL_SET:
+ switch (mode)
+ {
+ case SCM_EXPANDED_TOPLEVEL_REF:
+ case SCM_EXPANDED_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;
- }
+ 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_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_SETCDR (m, var);
- return var;
- }
+ case SCM_EXPANDED_TOPLEVEL_DEFINE:
+ {
+ return scm_module_ensure_local_variable (mod, loc);
+ }
- 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;
- }
+ 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, m);
+ scm_wrong_type_arg (FUNC_NAME, 1, loc);
return SCM_BOOL_F;
}
}
HCoop / bpt / guile.git / blobdiff