mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-20 19:50:24 +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:
parent
a3cae847d0
commit
e6a42e6765
5 changed files with 156 additions and 212 deletions
|
@ -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:
|
||||||
|
{
|
||||||
|
SCM box = mx;
|
||||||
|
|
||||||
|
return scm_variable_ref (EVAL1 (box, env));
|
||||||
|
}
|
||||||
|
|
||||||
|
case SCM_M_BOX_SET:
|
||||||
|
{
|
||||||
|
SCM box = CAR (mx), val = CDR (mx);
|
||||||
|
|
||||||
|
return scm_variable_set_x (EVAL1 (box, env), EVAL1 (val, env));
|
||||||
|
}
|
||||||
|
|
||||||
|
case SCM_M_RESOLVE:
|
||||||
if (SCM_VARIABLEP (mx))
|
if (SCM_VARIABLEP (mx))
|
||||||
return SCM_VARIABLE_REF (mx);
|
return mx;
|
||||||
else
|
else
|
||||||
{
|
{
|
||||||
env = env_tail (env);
|
SCM mod, var;
|
||||||
return SCM_VARIABLE_REF (scm_memoize_variable_access_x (x, env));
|
|
||||||
}
|
|
||||||
|
|
||||||
case SCM_M_TOPLEVEL_SET:
|
var = scm_sys_resolve_variable (mx, env_tail (env));
|
||||||
{
|
scm_set_cdr_x (x, var);
|
||||||
SCM var = CAR (mx);
|
|
||||||
SCM val = EVAL1 (CDR (mx), env);
|
|
||||||
if (SCM_VARIABLEP (var))
|
|
||||||
{
|
|
||||||
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:
|
return var;
|
||||||
if (SCM_VARIABLEP (mx))
|
|
||||||
return SCM_VARIABLE_REF (mx);
|
|
||||||
else
|
|
||||||
return SCM_VARIABLE_REF
|
|
||||||
(scm_memoize_variable_access_x (x, SCM_BOOL_F));
|
|
||||||
|
|
||||||
case SCM_M_MODULE_SET:
|
|
||||||
if (SCM_VARIABLEP (CDR (mx)))
|
|
||||||
{
|
|
||||||
SCM_VARIABLE_SET (CDR (mx), EVAL1 (CAR (mx), env));
|
|
||||||
return SCM_UNSPECIFIED;
|
|
||||||
}
|
|
||||||
else
|
|
||||||
{
|
|
||||||
SCM_VARIABLE_SET
|
|
||||||
(scm_memoize_variable_access_x (x, SCM_BOOL_F),
|
|
||||||
EVAL1 (CAR (mx), env));
|
|
||||||
return SCM_UNSPECIFIED;
|
|
||||||
}
|
}
|
||||||
|
|
||||||
case SCM_M_CALL_WITH_PROMPT:
|
case SCM_M_CALL_WITH_PROMPT:
|
||||||
|
|
|
@ -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:
|
||||||
{
|
{
|
||||||
|
|
|
@ -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
|
||||||
|
(SCM_EXPANDED_MODULE_REF,
|
||||||
|
REF (exp, MODULE_REF, MOD),
|
||||||
REF (exp, MODULE_REF, NAME),
|
REF (exp, MODULE_REF, NAME),
|
||||||
REF (exp, MODULE_REF, PUBLIC));
|
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
|
||||||
|
(SCM_EXPANDED_MODULE_SET,
|
||||||
REF (exp, MODULE_SET, MOD),
|
REF (exp, MODULE_SET, MOD),
|
||||||
REF (exp, MODULE_SET, NAME),
|
REF (exp, MODULE_SET, NAME),
|
||||||
REF (exp, MODULE_SET, PUBLIC));
|
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));
|
||||||
|
|
||||||
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, new_env);
|
proc = memoize (body, new_env);
|
||||||
SCM_SETCAR (SCM_CDR (SCM_MEMOIZED_ARGS (proc)), meta);
|
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);
|
||||||
|
|
||||||
|
switch (mode)
|
||||||
{
|
{
|
||||||
case SCM_M_TOPLEVEL_REF:
|
case SCM_EXPANDED_TOPLEVEL_REF:
|
||||||
if (SCM_VARIABLEP (mx))
|
case SCM_EXPANDED_TOPLEVEL_SET:
|
||||||
return mx;
|
|
||||||
else
|
|
||||||
{
|
{
|
||||||
SCM var = scm_module_variable (mod, mx);
|
SCM var = scm_module_variable (mod, loc);
|
||||||
if (scm_is_false (var) || scm_is_false (scm_variable_bound_p (var)))
|
if (scm_is_false (var)
|
||||||
error_unbound_variable (mx);
|
|| (mode == SCM_EXPANDED_TOPLEVEL_REF
|
||||||
SCM_SETCDR (m, var);
|
&& scm_is_false (scm_variable_bound_p (var))))
|
||||||
|
error_unbound_variable (loc);
|
||||||
return var;
|
return var;
|
||||||
}
|
}
|
||||||
|
|
||||||
case SCM_M_TOPLEVEL_SET:
|
case SCM_EXPANDED_TOPLEVEL_DEFINE:
|
||||||
{
|
{
|
||||||
SCM var = CAR (mx);
|
return scm_module_ensure_local_variable (mod, loc);
|
||||||
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:
|
case SCM_EXPANDED_MODULE_REF:
|
||||||
if (SCM_VARIABLEP (mx))
|
case SCM_EXPANDED_MODULE_SET:
|
||||||
return mx;
|
|
||||||
else
|
|
||||||
{
|
{
|
||||||
SCM var;
|
SCM var;
|
||||||
mod = scm_resolve_module (CAR (mx));
|
mod = scm_resolve_module (scm_car (loc));
|
||||||
if (scm_is_true (CDDR (mx)))
|
if (scm_is_true (scm_cddr (loc)))
|
||||||
mod = scm_module_public_interface (mod);
|
mod = scm_module_public_interface (mod);
|
||||||
var = scm_module_lookup (mod, CADR (mx));
|
var = scm_module_lookup (mod, scm_cadr (loc));
|
||||||
if (scm_is_false (scm_variable_bound_p (var)))
|
if (mode == SCM_EXPANDED_MODULE_SET
|
||||||
error_unbound_variable (CADR (mx));
|
&& scm_is_false (scm_variable_bound_p (var)))
|
||||||
SCM_SETCDR (m, var);
|
error_unbound_variable (scm_cadr (loc));
|
||||||
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;
|
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;
|
||||||
}
|
}
|
||||||
}
|
}
|
||||||
|
|
|
@ -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);
|
||||||
|
|
||||||
|
|
|
@ -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)
|
||||||
|
|
Loading…
Add table
Add a link
Reference in a new issue