X-Git-Url: https://git.hcoop.net/bpt/guile.git/blobdiff_plain/5dfafc3c76b70acfdb7d47611478d1f9a737ac18..eb0376567da2dd8031f7cdf9c26b261d6e8583dc:/libguile/memoize.c diff --git a/libguile/memoize.c b/libguile/memoize.c index 5c7129feb..1267d4771 100644 --- a/libguile/memoize.c +++ b/libguile/memoize.c @@ -1,5 +1,5 @@ /* 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 @@ -119,18 +119,18 @@ scm_t_bits scm_tc16_memoized; 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)\ @@ -139,20 +139,22 @@ scm_t_bits scm_tc16_memoized; 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))) @@ -165,9 +167,9 @@ static const char *const memoized_tags[] = "seq", "if", "lambda", + "capture-env", "let", "quote", - "define", "capture-module", "apply", "call/cc", @@ -175,10 +177,9 @@ static const char *const memoized_tags[] = "call", "lexical-ref", "lexical-set!", - "toplevel-ref", - "toplevel-set!", - "module-ref", - "module-set!", + "box-ref", + "box-set!", + "resolve", "call-with-prompt", }; @@ -186,6 +187,31 @@ static const char *const memoized_tags[] = +/* 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) { @@ -211,20 +237,87 @@ 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++) { - 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))) @@ -275,11 +368,14 @@ memoize (SCM exp, SCM env) 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)); @@ -289,30 +385,41 @@ memoize (SCM exp, SCM 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), @@ -326,7 +433,7 @@ memoize (SCM exp, SCM 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: @@ -355,26 +462,39 @@ memoize (SCM exp, SCM env) && 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); } @@ -383,43 +503,25 @@ memoize (SCM exp, SCM env) 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))); @@ -432,17 +534,13 @@ memoize (SCM exp, SCM env) 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)) { @@ -468,13 +566,14 @@ memoize (SCM exp, SCM env) 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: @@ -489,7 +588,7 @@ memoize (SCM exp, SCM env) 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)); @@ -497,64 +596,6 @@ memoize (SCM exp, SCM 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 (); } @@ -569,7 +610,7 @@ SCM_DEFINE (scm_memoize_expression, "memoize-expression", 1, 0, 0, #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 @@ -633,7 +674,7 @@ unmemoize (const SCM expr) 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"), @@ -641,8 +682,6 @@ unmemoize (const SCM expr) 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)); @@ -670,7 +709,7 @@ unmemoize (const SCM expr) { SCM alt, tail; - alt = CADDR (CDDDR (spec)); + alt = CADDDR (CDDDR (spec)); if (scm_is_true (alt)) tail = CDR (unmemoize (alt)); else @@ -682,11 +721,15 @@ unmemoize (const SCM expr) 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)), @@ -698,23 +741,23 @@ unmemoize (const SCM expr) 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)), @@ -762,78 +805,53 @@ static void error_unbound_variable (SCM symbol) 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; } }