1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00

Simplify variable resolution in the evaluator

* libguile/expand.c (convert_assignment): Handle creation of the default
  lambda-case body here.

* libguile/eval.c (eval):
* module/ice-9/eval.scm (primitive-eval):

* libguile/memoize.h:
* libguile/memoize.c (MAKMEMO_BOX_REF, MAKMEMO_BOX_SET):
  (MAKMEMO_TOP_BOX, MAKMEMO_MOD_BOX): Refactor all global var resolution
  to go through "resolve".  Add "box-ref" and "box-set!".  Rename
  memoize-variable-access! to %resolve-variable, and don't be
  destructive.
This commit is contained in:
Andy Wingo 2014-12-07 15:52:34 +01:00
parent a3cae847d0
commit e6a42e6765
5 changed files with 156 additions and 212 deletions

View file

@ -305,10 +305,6 @@ eval (SCM x, SCM env)
case SCM_M_QUOTE: case SCM_M_QUOTE:
return mx; return mx;
case SCM_M_DEFINE:
scm_define (CAR (mx), EVAL1 (CDR (mx), env));
return SCM_UNSPECIFIED;
case SCM_M_CAPTURE_MODULE: case SCM_M_CAPTURE_MODULE:
return eval (mx, scm_current_module ()); return eval (mx, scm_current_module ());
@ -398,51 +394,31 @@ eval (SCM x, SCM env)
return SCM_UNSPECIFIED; return SCM_UNSPECIFIED;
} }
case SCM_M_TOPLEVEL_REF: case SCM_M_BOX_REF:
if (SCM_VARIABLEP (mx))
return SCM_VARIABLE_REF (mx);
else
{
env = env_tail (env);
return SCM_VARIABLE_REF (scm_memoize_variable_access_x (x, env));
}
case SCM_M_TOPLEVEL_SET:
{ {
SCM var = CAR (mx); SCM box = mx;
SCM val = EVAL1 (CDR (mx), env);
if (SCM_VARIABLEP (var)) return scm_variable_ref (EVAL1 (box, env));
{
SCM_VARIABLE_SET (var, val);
return SCM_UNSPECIFIED;
}
else
{
env = env_tail (env);
SCM_VARIABLE_SET (scm_memoize_variable_access_x (x, env), val);
return SCM_UNSPECIFIED;
}
} }
case SCM_M_MODULE_REF: case SCM_M_BOX_SET:
if (SCM_VARIABLEP (mx)) {
return SCM_VARIABLE_REF (mx); SCM box = CAR (mx), val = CDR (mx);
else
return SCM_VARIABLE_REF
(scm_memoize_variable_access_x (x, SCM_BOOL_F));
case SCM_M_MODULE_SET: return scm_variable_set_x (EVAL1 (box, env), EVAL1 (val, env));
if (SCM_VARIABLEP (CDR (mx))) }
{
SCM_VARIABLE_SET (CDR (mx), EVAL1 (CAR (mx), env)); case SCM_M_RESOLVE:
return SCM_UNSPECIFIED; if (SCM_VARIABLEP (mx))
} return mx;
else else
{ {
SCM_VARIABLE_SET SCM mod, var;
(scm_memoize_variable_access_x (x, SCM_BOOL_F),
EVAL1 (CAR (mx), env)); var = scm_sys_resolve_variable (mx, env_tail (env));
return SCM_UNSPECIFIED; scm_set_cdr_x (x, var);
return var;
} }
case SCM_M_CALL_WITH_PROMPT: case SCM_M_CALL_WITH_PROMPT:

View file

@ -1412,7 +1412,21 @@ convert_assignment (SCM exp, SCM assigned)
return LAMBDA return LAMBDA
(REF (exp, LAMBDA, SRC), (REF (exp, LAMBDA, SRC),
REF (exp, LAMBDA, META), REF (exp, LAMBDA, META),
convert_assignment (REF (exp, LAMBDA, BODY), assigned)); scm_is_false (REF (exp, LAMBDA, BODY))
/* Give a body to case-lambda with no clauses. */
? LAMBDA_CASE (SCM_BOOL_F, SCM_EOL, SCM_EOL, SCM_BOOL_F, SCM_BOOL_F,
SCM_EOL, SCM_EOL,
PRIMCALL
(SCM_BOOL_F,
scm_from_latin1_symbol ("throw"),
scm_list_5 (CONST_ (SCM_BOOL_F, scm_args_number_key),
CONST_ (SCM_BOOL_F, SCM_BOOL_F),
CONST_ (SCM_BOOL_F, scm_from_latin1_string
("Wrong number of arguments")),
CONST_ (SCM_BOOL_F, SCM_EOL),
CONST_ (SCM_BOOL_F, SCM_BOOL_F))),
SCM_BOOL_F)
: convert_assignment (REF (exp, LAMBDA, BODY), assigned));
case SCM_EXPANDED_LAMBDA_CASE: case SCM_EXPANDED_LAMBDA_CASE:
{ {

View file

@ -131,8 +131,6 @@ scm_t_bits scm_tc16_memoized;
MAKMEMO (SCM_M_LET, scm_cons (inits, body)) MAKMEMO (SCM_M_LET, scm_cons (inits, body))
#define MAKMEMO_QUOTE(exp) \ #define MAKMEMO_QUOTE(exp) \
MAKMEMO (SCM_M_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) \ #define MAKMEMO_CAPTURE_MODULE(exp) \
MAKMEMO (SCM_M_CAPTURE_MODULE, exp) MAKMEMO (SCM_M_CAPTURE_MODULE, exp)
#define MAKMEMO_APPLY(proc, args)\ #define MAKMEMO_APPLY(proc, args)\
@ -147,14 +145,16 @@ scm_t_bits scm_tc16_memoized;
MAKMEMO (SCM_M_LEXICAL_REF, pos) MAKMEMO (SCM_M_LEXICAL_REF, pos)
#define MAKMEMO_LEX_SET(pos, val) \ #define MAKMEMO_LEX_SET(pos, val) \
MAKMEMO (SCM_M_LEXICAL_SET, scm_cons (pos, val)) MAKMEMO (SCM_M_LEXICAL_SET, scm_cons (pos, val))
#define MAKMEMO_TOP_REF(var) \ #define MAKMEMO_BOX_REF(box) \
MAKMEMO (SCM_M_TOPLEVEL_REF, var) MAKMEMO (SCM_M_BOX_REF, box)
#define MAKMEMO_TOP_SET(var, val) \ #define MAKMEMO_BOX_SET(box, val) \
MAKMEMO (SCM_M_TOPLEVEL_SET, scm_cons (var, val)) MAKMEMO (SCM_M_BOX_SET, scm_cons (box, val))
#define MAKMEMO_MOD_REF(mod, var, public) \ #define MAKMEMO_TOP_BOX(mode, var) \
MAKMEMO (SCM_M_MODULE_REF, scm_cons (mod, scm_cons (var, public))) MAKMEMO (SCM_M_RESOLVE, scm_cons (SCM_I_MAKINUM (mode), var))
#define MAKMEMO_MOD_SET(val, mod, var, public) \ #define MAKMEMO_MOD_BOX(mode, mod, var, public) \
MAKMEMO (SCM_M_MODULE_SET, scm_cons (val, scm_cons (mod, scm_cons (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) \ #define MAKMEMO_CALL_WITH_PROMPT(tag, thunk, handler) \
MAKMEMO (SCM_M_CALL_WITH_PROMPT, scm_cons (tag, scm_cons (thunk, handler))) MAKMEMO (SCM_M_CALL_WITH_PROMPT, scm_cons (tag, scm_cons (thunk, handler)))
@ -170,7 +170,6 @@ static const char *const memoized_tags[] =
"capture-env", "capture-env",
"let", "let",
"quote", "quote",
"define",
"capture-module", "capture-module",
"apply", "apply",
"call/cc", "call/cc",
@ -178,10 +177,9 @@ static const char *const memoized_tags[] =
"call", "call",
"lexical-ref", "lexical-ref",
"lexical-set!", "lexical-set!",
"toplevel-ref", "box-ref",
"toplevel-set!", "box-set!",
"module-ref", "resolve",
"module-set!",
"call-with-prompt", "call-with-prompt",
}; };
@ -370,11 +368,14 @@ memoize (SCM exp, SCM env)
case SCM_EXPANDED_PRIMITIVE_REF: case SCM_EXPANDED_PRIMITIVE_REF:
if (scm_is_eq (scm_current_module (), scm_the_root_module ())) if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
return maybe_makmemo_capture_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); env);
else else
return MAKMEMO_MOD_REF (list_of_guile, REF (exp, PRIMITIVE_REF, NAME), return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF,
SCM_BOOL_F); list_of_guile,
REF (exp, PRIMITIVE_REF, NAME),
SCM_BOOL_F));
case SCM_EXPANDED_LEXICAL_REF: case SCM_EXPANDED_LEXICAL_REF:
return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env)); return MAKMEMO_LEX_REF (lookup (REF (exp, LEXICAL_REF, GENSYM), env));
@ -384,30 +385,41 @@ memoize (SCM exp, SCM env)
memoize (REF (exp, LEXICAL_SET, EXP), env)); memoize (REF (exp, LEXICAL_SET, EXP), env));
case SCM_EXPANDED_MODULE_REF: case SCM_EXPANDED_MODULE_REF:
return MAKMEMO_MOD_REF (REF (exp, MODULE_REF, MOD), return MAKMEMO_BOX_REF (MAKMEMO_MOD_BOX
REF (exp, MODULE_REF, NAME), (SCM_EXPANDED_MODULE_REF,
REF (exp, MODULE_REF, PUBLIC)); REF (exp, MODULE_REF, MOD),
REF (exp, MODULE_REF, NAME),
REF (exp, MODULE_REF, PUBLIC)));
case SCM_EXPANDED_MODULE_SET: case SCM_EXPANDED_MODULE_SET:
return MAKMEMO_MOD_SET (memoize (REF (exp, MODULE_SET, EXP), env), return MAKMEMO_BOX_SET (MAKMEMO_MOD_BOX
REF (exp, MODULE_SET, MOD), (SCM_EXPANDED_MODULE_SET,
REF (exp, MODULE_SET, NAME), REF (exp, MODULE_SET, MOD),
REF (exp, MODULE_SET, PUBLIC)); REF (exp, MODULE_SET, NAME),
REF (exp, MODULE_SET, PUBLIC)),
memoize (REF (exp, MODULE_SET, EXP), env));
case SCM_EXPANDED_TOPLEVEL_REF: case SCM_EXPANDED_TOPLEVEL_REF:
return maybe_makmemo_capture_module 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: case SCM_EXPANDED_TOPLEVEL_SET:
return maybe_makmemo_capture_module 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), memoize (REF (exp, TOPLEVEL_SET, EXP),
capture_env (env))), capture_env (env))),
env); env);
case SCM_EXPANDED_TOPLEVEL_DEFINE: case SCM_EXPANDED_TOPLEVEL_DEFINE:
return MAKMEMO_DEFINE (REF (exp, TOPLEVEL_DEFINE, NAME), return maybe_makmemo_capture_module
memoize (REF (exp, TOPLEVEL_DEFINE, EXP), env)); (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: case SCM_EXPANDED_CONDITIONAL:
return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env), return MAKMEMO_IF (memoize (REF (exp, CONDITIONAL, TEST), env),
@ -450,6 +462,14 @@ memoize (SCM exp, SCM env)
&& scm_is_eq (name, && scm_is_eq (name,
scm_from_latin1_symbol ("call-with-values"))) scm_from_latin1_symbol ("call-with-values")))
return MAKMEMO_CALL_WITH_VALUES (CAR (args), CADR (args)); 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 else if (nargs == 2
&& scm_is_eq (name, scm_from_latin1_symbol ("wind"))) && scm_is_eq (name, scm_from_latin1_symbol ("wind")))
return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), 2, args); return MAKMEMO_CALL (MAKMEMO_QUOTE (wind), 2, args);
@ -464,11 +484,17 @@ memoize (SCM exp, SCM env)
return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), 0, SCM_EOL); return MAKMEMO_CALL (MAKMEMO_QUOTE (pop_fluid), 0, SCM_EOL);
else if (scm_is_eq (scm_current_module (), scm_the_root_module ())) else if (scm_is_eq (scm_current_module (), scm_the_root_module ()))
return MAKMEMO_CALL (maybe_makmemo_capture_module return MAKMEMO_CALL (maybe_makmemo_capture_module
(MAKMEMO_TOP_REF (name), env), (MAKMEMO_BOX_REF
(MAKMEMO_TOP_BOX (SCM_EXPANDED_TOPLEVEL_REF,
name)),
env),
nargs, args); nargs, args);
else else
return MAKMEMO_CALL (MAKMEMO_MOD_REF (list_of_guile, name, return MAKMEMO_CALL (MAKMEMO_BOX_REF
SCM_BOOL_F), (MAKMEMO_MOD_BOX (SCM_EXPANDED_MODULE_REF,
list_of_guile,
name,
SCM_BOOL_F)),
nargs, nargs,
args); args);
} }
@ -478,35 +504,15 @@ memoize (SCM exp, SCM env)
memoize (REF (exp, SEQ, TAIL), env)); memoize (REF (exp, SEQ, TAIL), env));
case SCM_EXPANDED_LAMBDA: case SCM_EXPANDED_LAMBDA:
/* The body will be a lambda-case or #f. */ /* The body will be a lambda-case. */
{ {
SCM meta, body, proc, new_env; SCM meta, body, proc, new_env;
meta = REF (exp, LAMBDA, META); meta = REF (exp, LAMBDA, META);
body = REF (exp, LAMBDA, BODY); body = REF (exp, LAMBDA, BODY);
new_env = push_flat_link (capture_env (env)); new_env = push_flat_link (capture_env (env));
proc = memoize (body, new_env);
if (scm_is_false (body)) SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta);
/* 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, new_env);
SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta);
}
return maybe_makmemo_capture_module (capture_flat_env (proc, new_env), return maybe_makmemo_capture_module (capture_flat_env (proc, new_env),
env); env);
@ -677,8 +683,6 @@ unmemoize (const SCM expr)
case SCM_M_CALL_WITH_VALUES: case SCM_M_CALL_WITH_VALUES:
return scm_list_3 (scm_from_latin1_symbol ("call-with-values"), return scm_list_3 (scm_from_latin1_symbol ("call-with-values"),
unmemoize (CAR (args)), unmemoize (CDR (args))); 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: case SCM_M_CAPTURE_MODULE:
return scm_list_2 (scm_from_latin1_symbol ("capture-module"), return scm_list_2 (scm_from_latin1_symbol ("capture-module"),
unmemoize (args)); unmemoize (args));
@ -738,23 +742,18 @@ unmemoize (const SCM expr)
case SCM_M_LEXICAL_SET: case SCM_M_LEXICAL_SET:
return scm_list_3 (scm_sym_set_x, unmemoize_lexical (CAR (args)), return scm_list_3 (scm_sym_set_x, unmemoize_lexical (CAR (args)),
unmemoize (CDR (args))); unmemoize (CDR (args)));
case SCM_M_TOPLEVEL_REF: case SCM_M_BOX_REF:
return args; return scm_list_2 (scm_from_latin1_symbol ("variable-ref"),
case SCM_M_TOPLEVEL_SET: unmemoize (args));
return scm_list_3 (scm_sym_set_x, CAR (args), unmemoize (CDR (args))); case SCM_M_BOX_SET:
case SCM_M_MODULE_REF: return scm_list_3 (scm_from_latin1_symbol ("variable-set!"),
return SCM_VARIABLEP (args) ? args unmemoize (CAR (args)),
unmemoize (CDR (args)));
case SCM_M_RESOLVE:
return (SCM_VARIABLEP (args) || scm_is_symbol (args)) ? args
: scm_list_3 (scm_is_true (CDDR (args)) ? scm_sym_at : scm_sym_atat, : scm_list_3 (scm_is_true (CDDR (args)) ? scm_sym_at : scm_sym_atat,
scm_i_finite_list_copy (CAR (args)), scm_i_finite_list_copy (CAR (args)),
CADR (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_CALL_WITH_PROMPT: case SCM_M_CALL_WITH_PROMPT:
return scm_list_4 (scm_from_latin1_symbol ("call-with-prompt"), return scm_list_4 (scm_from_latin1_symbol ("call-with-prompt"),
unmemoize (CAR (args)), unmemoize (CAR (args)),
@ -802,78 +801,53 @@ static void error_unbound_variable (SCM symbol)
scm_list_1 (symbol), SCM_BOOL_F); scm_list_1 (symbol), SCM_BOOL_F);
} }
SCM_DEFINE (scm_memoize_variable_access_x, "memoize-variable-access!", 2, 0, 0, SCM_DEFINE (scm_sys_resolve_variable, "%resolve-variable", 2, 0, 0,
(SCM m, SCM mod), (SCM loc, SCM mod),
"Look up and cache the variable that @var{m} will access, returning the variable.") "Look up and return the variable for @var{loc}.")
#define FUNC_NAME s_scm_memoize_variable_access_x #define FUNC_NAME s_scm_sys_resolve_variable
{ {
SCM mx = SCM_MEMOIZED_ARGS (m); int mode;
if (scm_is_false (mod)) if (scm_is_false (mod))
mod = scm_the_root_module (); mod = scm_the_root_module ();
switch (SCM_MEMOIZED_TAG (m)) mode = scm_to_int (scm_car (loc));
{ loc = scm_cdr (loc);
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;
}
case SCM_M_TOPLEVEL_SET: switch (mode)
{
case SCM_EXPANDED_TOPLEVEL_REF:
case SCM_EXPANDED_TOPLEVEL_SET:
{ {
SCM var = CAR (mx); SCM var = scm_module_variable (mod, loc);
if (SCM_VARIABLEP (var)) if (scm_is_false (var)
return var; || (mode == SCM_EXPANDED_TOPLEVEL_REF
else && scm_is_false (scm_variable_bound_p (var))))
{ error_unbound_variable (loc);
var = scm_module_variable (mod, var); return var;
if (scm_is_false (var))
error_unbound_variable (CAR (mx));
SCM_SETCAR (mx, var);
return var;
}
} }
case SCM_M_MODULE_REF: case SCM_EXPANDED_TOPLEVEL_DEFINE:
if (SCM_VARIABLEP (mx)) {
return mx; return scm_module_ensure_local_variable (mod, loc);
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_M_MODULE_SET: case SCM_EXPANDED_MODULE_REF:
/* FIXME: not quite threadsafe */ case SCM_EXPANDED_MODULE_SET:
if (SCM_VARIABLEP (CDR (mx))) {
return CDR (mx); SCM var;
else mod = scm_resolve_module (scm_car (loc));
{ if (scm_is_true (scm_cddr (loc)))
SCM var; mod = scm_module_public_interface (mod);
mod = scm_resolve_module (CADR (mx)); var = scm_module_lookup (mod, scm_cadr (loc));
if (scm_is_true (CDDDR (mx))) if (mode == SCM_EXPANDED_MODULE_SET
mod = scm_module_public_interface (mod); && scm_is_false (scm_variable_bound_p (var)))
var = scm_module_lookup (mod, CADDR (mx)); error_unbound_variable (scm_cadr (loc));
SCM_SETCDR (mx, var); return var;
return var; }
}
default: default:
scm_wrong_type_arg (FUNC_NAME, 1, m); scm_wrong_type_arg (FUNC_NAME, 1, loc);
return SCM_BOOL_F; return SCM_BOOL_F;
} }
} }

View file

@ -69,7 +69,6 @@ enum
SCM_M_CAPTURE_ENV, SCM_M_CAPTURE_ENV,
SCM_M_LET, SCM_M_LET,
SCM_M_QUOTE, SCM_M_QUOTE,
SCM_M_DEFINE,
SCM_M_CAPTURE_MODULE, SCM_M_CAPTURE_MODULE,
SCM_M_APPLY, SCM_M_APPLY,
SCM_M_CONT, SCM_M_CONT,
@ -77,10 +76,9 @@ enum
SCM_M_CALL, SCM_M_CALL,
SCM_M_LEXICAL_REF, SCM_M_LEXICAL_REF,
SCM_M_LEXICAL_SET, SCM_M_LEXICAL_SET,
SCM_M_TOPLEVEL_REF, SCM_M_BOX_REF,
SCM_M_TOPLEVEL_SET, SCM_M_BOX_SET,
SCM_M_MODULE_REF, SCM_M_RESOLVE,
SCM_M_MODULE_SET,
SCM_M_CALL_WITH_PROMPT SCM_M_CALL_WITH_PROMPT
}; };
@ -90,7 +88,7 @@ enum
SCM_INTERNAL SCM scm_memoize_expression (SCM exp); SCM_INTERNAL SCM scm_memoize_expression (SCM exp);
SCM_INTERNAL SCM scm_unmemoize_expression (SCM memoized); SCM_INTERNAL SCM scm_unmemoize_expression (SCM memoized);
SCM_INTERNAL SCM scm_memoized_typecode (SCM sym); SCM_INTERNAL SCM scm_memoized_typecode (SCM sym);
SCM_INTERNAL SCM scm_memoize_variable_access_x (SCM memoized, SCM module); SCM_INTERNAL SCM scm_sys_resolve_variable (SCM loc, SCM module);
SCM_INTERNAL void scm_init_memoize (void); SCM_INTERNAL void scm_init_memoize (void);

View file

@ -463,11 +463,15 @@
(let ((proc (eval f env))) (let ((proc (eval f env)))
(call eval proc nargs args env))) (call eval proc nargs args env)))
(('toplevel-ref var-or-sym) (('box-ref box)
(variable-ref (variable-ref (eval box env)))
(if (variable? var-or-sym)
var-or-sym (('resolve var-or-loc)
(memoize-variable-access! exp (env-toplevel env))))) (if (variable? var-or-loc)
var-or-loc
(let ((var (%resolve-variable var-or-loc (env-toplevel env))))
(set-cdr! exp var)
var)))
(('if (test consequent . alternate)) (('if (test consequent . alternate))
(if (eval test env) (if (eval test env)
@ -515,6 +519,9 @@
(eval head env) (eval head env)
(eval tail env))) (eval tail env)))
(('box-set! (box . val))
(variable-set! (eval box env) (eval val env)))
(('lexical-set! ((depth . width) . x)) (('lexical-set! ((depth . width) . x))
(env-set! env depth width (eval x env))) (env-set! env depth width (eval x env)))
@ -525,27 +532,9 @@
(('apply (f args)) (('apply (f args))
(apply (eval f env) (eval args env))) (apply (eval f env) (eval args env)))
(('module-ref var-or-spec)
(variable-ref
(if (variable? var-or-spec)
var-or-spec
(memoize-variable-access! exp #f))))
(('define (name . x))
(begin
(define! name (eval x env))
(if #f #f)))
(('capture-module x) (('capture-module x)
(eval x (current-module))) (eval x (current-module)))
(('toplevel-set! (var-or-sym . x))
(variable-set!
(if (variable? var-or-sym)
var-or-sym
(memoize-variable-access! exp (env-toplevel env)))
(eval x env)))
(('call-with-prompt (tag thunk . handler)) (('call-with-prompt (tag thunk . handler))
(call-with-prompt (call-with-prompt
(eval tag env) (eval tag env)
@ -553,14 +542,7 @@
(eval handler env))) (eval handler env)))
(('call/cc proc) (('call/cc proc)
(call/cc (eval proc env))) (call/cc (eval proc env)))))
(('module-set! (x . var-or-spec))
(variable-set!
(if (variable? var-or-spec)
var-or-spec
(memoize-variable-access! exp #f))
(eval x env)))))
;; primitive-eval ;; primitive-eval
(lambda (exp) (lambda (exp)