diff options
-rw-r--r-- | libguile/eval.c | 236 | ||||
-rw-r--r-- | libguile/memoize.c | 194 | ||||
-rw-r--r-- | module/ice-9/eval.scm | 331 |
3 files changed, 424 insertions, 337 deletions
diff --git a/libguile/eval.c b/libguile/eval.c index 205de2d1a..36199a60b 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -153,6 +153,48 @@ static void prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc, #define CADDR(x) SCM_CADDR(x) #define CDDDR(x) SCM_CDDDR(x) +#define VECTOR_REF(v, i) (SCM_SIMPLE_VECTOR_REF (v, i)) +#define VECTOR_SET(v, i, x) (SCM_SIMPLE_VECTOR_SET (v, i, x)) +#define VECTOR_LENGTH(v) (SCM_SIMPLE_VECTOR_LENGTH (v)) + +static SCM +make_env (int n, SCM init, SCM next) +{ + SCM env = scm_c_make_vector (n + 1, init); + VECTOR_SET (env, 0, next); + return env; +} + +static SCM +next_rib (SCM env) +{ + return VECTOR_REF (env, 0); +} + +static SCM +env_tail (SCM env) +{ + while (SCM_I_IS_VECTOR (env)) + env = next_rib (env); + return env; +} + +static SCM +env_ref (SCM env, int depth, int width) +{ + while (depth--) + env = next_rib (env); + return VECTOR_REF (env, width + 1); +} + +static void +env_set (SCM env, int depth, int width, SCM val) +{ + while (depth--) + env = next_rib (env); + VECTOR_SET (env, width + 1, val); +} + SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable"); @@ -245,10 +287,13 @@ eval (SCM x, SCM env) case SCM_M_LET: { SCM inits = CAR (mx); - SCM new_env = CAPTURE_ENV (env); - for (; scm_is_pair (inits); inits = CDR (inits)) - new_env = scm_cons (EVAL1 (CAR (inits), env), - new_env); + SCM new_env; + int i; + + new_env = make_env (VECTOR_LENGTH (inits), SCM_UNDEFINED, + CAPTURE_ENV (env)); + for (i = 0; i < VECTOR_LENGTH (inits); i++) + env_set (new_env, 0, i, EVAL1 (VECTOR_REF (inits, i), env)); env = new_env; x = CDR (mx); goto loop; @@ -325,11 +370,15 @@ eval (SCM x, SCM env) case SCM_M_LEXICAL_REF: { - int n; - SCM ret; - for (n = SCM_I_INUM (mx); n; n--) - env = CDR (env); - ret = CAR (env); + SCM pos, ret; + int depth, width; + + pos = mx; + depth = SCM_I_INUM (CAR (pos)); + width = SCM_I_INUM (CDR (pos)); + + ret = env_ref (env, depth, width); + if (SCM_UNLIKELY (SCM_UNBNDP (ret))) /* we don't know what variable, though, because we don't have its name */ @@ -339,11 +388,16 @@ eval (SCM x, SCM env) case SCM_M_LEXICAL_SET: { - int n; + SCM pos; + int depth, width; SCM val = EVAL1 (CDR (mx), env); - for (n = SCM_I_INUM (CAR (mx)); n; n--) - env = CDR (env); - SCM_SETCAR (env, val); + + pos = CAR (mx); + depth = SCM_I_INUM (CAR (pos)); + width = SCM_I_INUM (CDR (pos)); + + env_set (env, depth, width, val); + return SCM_UNSPECIFIED; } @@ -352,8 +406,7 @@ eval (SCM x, SCM env) return SCM_VARIABLE_REF (mx); else { - while (scm_is_pair (env)) - env = CDR (env); + env = env_tail (env); return SCM_VARIABLE_REF (scm_memoize_variable_access_x (x, CAPTURE_ENV (env))); } @@ -369,8 +422,7 @@ eval (SCM x, SCM env) } else { - while (scm_is_pair (env)) - env = CDR (env); + env = env_tail (env); SCM_VARIABLE_SET (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)), val); @@ -683,15 +735,18 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, { int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc); SCM env = BOOT_CLOSURE_ENV (proc); - + int i; + if (BOOT_CLOSURE_IS_FIXED (proc) || (BOOT_CLOSURE_IS_REST (proc) && !BOOT_CLOSURE_HAS_REST_ARGS (proc))) { if (SCM_UNLIKELY (scm_ilength (args) != nreq)) scm_wrong_num_args (proc); - for (; scm_is_pair (args); args = CDR (args)) - env = scm_cons (CAR (args), env); + + env = make_env (nreq, SCM_UNDEFINED, env); + for (i = 0; i < nreq; args = CDR (args), i++) + env_set (env, 0, i, CAR (args)); *out_body = BOOT_CLOSURE_BODY (proc); *out_env = env; } @@ -699,15 +754,18 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, { if (SCM_UNLIKELY (scm_ilength (args) < nreq)) scm_wrong_num_args (proc); - for (; nreq; nreq--, args = CDR (args)) - env = scm_cons (CAR (args), env); - env = scm_cons (args, env); + + env = make_env (nreq + 1, SCM_UNDEFINED, env); + for (i = 0; i < nreq; args = CDR (args), i++) + env_set (env, 0, i, CAR (args)); + env_set (env, 0, i++, args); + *out_body = BOOT_CLOSURE_BODY (proc); *out_env = env; } else { - int i, argc, nreq, nopt; + int i, argc, nreq, nopt, nenv; SCM body, rest, kw, inits, alt; SCM mx = BOOT_CLOSURE_CODE (proc); @@ -735,25 +793,46 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, else scm_wrong_num_args (proc); } + if (scm_is_true (kw) && scm_is_false (rest)) + { + int npos = 0; + SCM walk; + for (walk = args; scm_is_pair (walk); walk = CDR (walk), npos++) + if (npos >= nreq && scm_is_keyword (CAR (walk))) + break; + + if (npos > nreq + nopt) + { + /* Too many positional args and no rest arg. */ + if (scm_is_true (alt)) + { + mx = alt; + goto loop; + } + else + scm_wrong_num_args (proc); + } + } + + /* At this point we are committed to the chosen clause. */ + nenv = nreq + (scm_is_true (rest) ? 1 : 0) + scm_ilength (inits); + env = make_env (nenv, SCM_UNDEFINED, env); for (i = 0; i < nreq; i++, args = CDR (args)) - env = scm_cons (CAR (args), env); + env_set (env, 0, i, CAR (args)); if (scm_is_false (kw)) { /* Optional args (possibly), but no keyword args. */ for (; i < argc && i < nreq + nopt; - i++, args = CDR (args)) - { - env = scm_cons (CAR (args), env); - inits = CDR (inits); - } + i++, args = CDR (args), inits = CDR (inits)) + env_set (env, 0, i, CAR (args)); for (; i < nreq + nopt; i++, inits = CDR (inits)) - env = scm_cons (EVAL1 (CAR (inits), env), env); + env_set (env, 0, i, EVAL1 (CAR (inits), env)); if (scm_is_true (rest)) - env = scm_cons (args, env); + env_set (env, 0, i++, args); } else { @@ -762,45 +841,27 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, aok = CAR (kw); kw = CDR (kw); - /* Keyword args. As before, but stop at the first keyword. */ + /* Optional args. As before, but stop at the first keyword. */ for (; i < argc && i < nreq + nopt && !scm_is_keyword (CAR (args)); i++, args = CDR (args), inits = CDR (inits)) - env = scm_cons (CAR (args), env); + env_set (env, 0, i, CAR (args)); for (; i < nreq + nopt; i++, inits = CDR (inits)) - env = scm_cons (EVAL1 (CAR (inits), env), env); + env_set (env, 0, i, EVAL1 (CAR (inits), env)); if (scm_is_true (rest)) - { - env = scm_cons (args, env); - i++; - } - else if (scm_is_true (alt) - && scm_is_pair (args) && !scm_is_keyword (CAR (args))) - { - /* Too many positional args, no rest arg, and we have an - alternate clause. */ - mx = alt; - goto loop; - } + env_set (env, 0, i++, args); - /* Now fill in env with unbound values, limn the rest of the args for - keywords, and fill in unbound values with their inits. */ + /* Parse keyword args. */ { - int imax = i - 1; int kw_start_idx = i; - SCM walk, k, v; - for (walk = kw; scm_is_pair (walk); walk = CDR (walk)) - if (SCM_I_INUM (CDAR (walk)) > imax) - imax = SCM_I_INUM (CDAR (walk)); - for (; i <= imax; i++) - env = scm_cons (SCM_UNDEFINED, env); + SCM walk; if (scm_is_pair (args) && scm_is_pair (CDR (args))) for (; scm_is_pair (args) && scm_is_pair (CDR (args)); args = CDR (args)) { - k = CAR (args); v = CADR (args); + SCM k = CAR (args), v = CADR (args); if (!scm_is_keyword (k)) { if (scm_is_true (rest)) @@ -811,10 +872,7 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, for (walk = kw; scm_is_pair (walk); walk = CDR (walk)) if (scm_is_eq (k, CAAR (walk))) { - /* Well... ok, list-set! isn't the nicest interface, but - hey. */ - int iset = imax - SCM_I_INUM (CDAR (walk)); - scm_list_set_x (env, SCM_I_MAKINUM (iset), v); + env_set (env, 0, SCM_I_INUM (CDAR (walk)), v); args = CDR (args); break; } @@ -826,15 +884,17 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, /* Now fill in unbound values, evaluating init expressions in their appropriate environment. */ - for (i = imax - kw_start_idx; scm_is_pair (inits); i--, inits = CDR (inits)) - { - SCM tail = scm_list_tail (env, SCM_I_MAKINUM (i)); - if (SCM_UNBNDP (CAR (tail))) - SCM_SETCAR (tail, EVAL1 (CAR (inits), CDR (tail))); - } + for (i = kw_start_idx; scm_is_pair (inits); i++, inits = CDR (inits)) + if (SCM_UNBNDP (env_ref (env, 0, i))) + env_set (env, 0, i, EVAL1 (CAR (inits), env)); } } + if (!scm_is_null (inits)) + abort (); + if (i != nenv) + abort (); + *out_body = body; *out_env = env; } @@ -846,32 +906,32 @@ prepare_boot_closure_env_for_eval (SCM proc, unsigned int argc, { int nreq = BOOT_CLOSURE_NUM_REQUIRED_ARGS (proc); SCM new_env = BOOT_CLOSURE_ENV (proc); - if (BOOT_CLOSURE_IS_FIXED (proc) - || (BOOT_CLOSURE_IS_REST (proc) - && !BOOT_CLOSURE_HAS_REST_ARGS (proc))) + if ((BOOT_CLOSURE_IS_FIXED (proc) + || (BOOT_CLOSURE_IS_REST (proc) + && !BOOT_CLOSURE_HAS_REST_ARGS (proc))) + && nreq == argc) { - for (; scm_is_pair (exps); exps = CDR (exps), nreq--) - new_env = scm_cons (EVAL1 (CAR (exps), *inout_env), - new_env); - if (SCM_UNLIKELY (nreq != 0)) - scm_wrong_num_args (proc); + int i; + + new_env = make_env (nreq, SCM_UNDEFINED, new_env); + for (i = 0; i < nreq; exps = CDR (exps), i++) + env_set (new_env, 0, i, EVAL1 (CAR (exps), *inout_env)); + *out_body = BOOT_CLOSURE_BODY (proc); *inout_env = new_env; } - else if (BOOT_CLOSURE_IS_REST (proc)) + else if (BOOT_CLOSURE_IS_REST (proc) && argc >= nreq) { - if (SCM_UNLIKELY (argc < nreq)) - scm_wrong_num_args (proc); - for (; nreq; nreq--, exps = CDR (exps)) - new_env = scm_cons (EVAL1 (CAR (exps), *inout_env), - new_env); - { - SCM rest = SCM_EOL; - for (; scm_is_pair (exps); exps = CDR (exps)) - rest = scm_cons (EVAL1 (CAR (exps), *inout_env), rest); - new_env = scm_cons (scm_reverse (rest), - new_env); - } + SCM rest; + int i; + + new_env = make_env (nreq + 1, SCM_UNDEFINED, new_env); + for (i = 0; i < nreq; exps = CDR (exps), i++) + env_set (new_env, 0, i, EVAL1 (CAR (exps), *inout_env)); + for (rest = SCM_EOL; scm_is_pair (exps); exps = CDR (exps)) + rest = scm_cons (EVAL1 (CAR (exps), *inout_env), rest); + env_set (new_env, 0, i++, scm_reverse_x (rest, SCM_UNDEFINED)); + *out_body = BOOT_CLOSURE_BODY (proc); *inout_env = new_env; } diff --git a/libguile/memoize.c b/libguile/memoize.c index daad14a18..f54feb0ec 100644 --- a/libguile/memoize.c +++ b/libguile/memoize.c @@ -54,6 +54,9 @@ #define CDDDR(x) SCM_CDDDR(x) #define CADDDR(x) SCM_CADDDR(x) +#define VECTOR_REF(v, i) (SCM_SIMPLE_VECTOR_REF (v, i)) +#define VECTOR_SET(v, i, x) (SCM_SIMPLE_VECTOR_SET (v, i, x)) +#define VECTOR_LENGTH(v) (SCM_SIMPLE_VECTOR_LENGTH (v)) SCM_SYMBOL (sym_case_lambda_star, "case-lambda*"); @@ -136,10 +139,10 @@ scm_t_bits scm_tc16_memoized; 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_LEX_REF(n) \ - MAKMEMO (SCM_M_LEXICAL_REF, SCM_I_MAKINUM (n)) -#define MAKMEMO_LEX_SET(n, val) \ - MAKMEMO (SCM_M_LEXICAL_SET, scm_cons (SCM_I_MAKINUM (n), val)) +#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) \ @@ -190,16 +193,44 @@ scm_print_memoized (SCM memoized, SCM port, scm_print_state *pstate) static int +try_lookup_rib (SCM x, SCM rib) +{ + int idx = 0; + for (; idx < VECTOR_LENGTH (rib); idx++) + if (scm_is_eq (x, VECTOR_REF (rib, idx))) + return idx; /* bound */ + return -1; +} + +static int +lookup_rib (SCM x, SCM rib) +{ + int idx = try_lookup_rib (x, rib); + if (idx < 0) + abort (); + return idx; +} + +static SCM +make_pos (int depth, int width) +{ + return scm_cons (SCM_I_MAKINUM (depth), SCM_I_MAKINUM (width)); +} + +static SCM lookup (SCM x, SCM env) { - int i = 0; - for (; scm_is_pair (env); env = CDR (env), i++) - if (scm_is_eq (x, CAR (env))) - return i; /* bound */ + 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); + } abort (); } - /* 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))) @@ -373,8 +404,8 @@ memoize (SCM exp, SCM env) case SCM_EXPANDED_LAMBDA_CASE: { SCM req, rest, opt, kw, inits, vars, body, alt; - SCM walk, minits, arity, new_env; - int nreq, nopt, ntotal; + SCM walk, minits, arity, rib, new_env; + int nreq, nopt; req = REF (exp, LAMBDA_CASE, REQ); rest = scm_not (scm_not (REF (exp, LAMBDA_CASE, REST))); @@ -387,38 +418,16 @@ memoize (SCM exp, SCM env) nreq = scm_ilength (req); nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0; - ntotal = scm_ilength (vars); /* The vars are the gensyms, according to the divine plan. But we need to memoize the inits within their appropriate environment, complicating things. */ - new_env = env; - for (walk = req; scm_is_pair (walk); - walk = CDR (walk), vars = CDR (vars)) - new_env = scm_cons (CAR (vars), new_env); + rib = scm_vector (vars); + new_env = scm_cons (rib, env); minits = SCM_EOL; - for (walk = opt; scm_is_pair (walk); - walk = CDR (walk), vars = CDR (vars), inits = CDR (inits)) - { - minits = scm_cons (memoize (CAR (inits), new_env), minits); - new_env = scm_cons (CAR (vars), new_env); - } - - if (scm_is_true (rest)) - { - new_env = scm_cons (CAR (vars), new_env); - vars = CDR (vars); - } - - for (; scm_is_pair (inits); vars = CDR (vars), inits = CDR (inits)) - { - minits = scm_cons (memoize (CAR (inits), new_env), minits); - new_env = scm_cons (CAR (vars), new_env); - } - if (!scm_is_null (vars)) - abort (); - + 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); if (scm_is_true (kw)) @@ -431,7 +440,7 @@ memoize (SCM exp, SCM env) int idx; k = CAR (CAR (kw)); - idx = ntotal - 1 - lookup (CADDR (CAR (kw)), new_env); + idx = lookup_rib (CADDR (CAR (kw)), rib); indices = scm_acons (k, SCM_I_MAKINUM (idx), indices); } kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED)); @@ -456,79 +465,74 @@ memoize (SCM exp, SCM env) case SCM_EXPANDED_LET: { - SCM vars, exps, body, inits, new_env; + SCM vars, exps, body, varsv, inits, new_env; + int i; vars = REF (exp, LET, GENSYMS); exps = REF (exp, LET, VALS); body = REF (exp, LET, BODY); - inits = SCM_EOL; - new_env = env; - for (; scm_is_pair (vars); vars = CDR (vars), exps = CDR (exps)) - { - new_env = scm_cons (CAR (vars), new_env); - inits = scm_cons (memoize (CAR (exps), env), inits); - } - - return MAKMEMO_LET (scm_reverse_x (inits, SCM_UNDEFINED), - memoize (body, new_env)); + varsv = scm_vector (vars); + inits = scm_c_make_vector (VECTOR_LENGTH (varsv), + SCM_BOOL_F); + new_env = scm_cons (varsv, 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)); } case SCM_EXPANDED_LETREC: { - SCM vars, exps, body, undefs, new_env; + 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)); - nvars = i = scm_ilength (vars); - undefs = SCM_EOL; - new_env = env; - for (; scm_is_pair (vars); vars = CDR (vars)) - { - new_env = scm_cons (CAR (vars), new_env); - undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs); - } + 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, env); if (in_order_p) { - SCM body_exps = SCM_EOL, seq; - for (; scm_is_pair (exps); exps = CDR (exps), i--) - body_exps = scm_cons (MAKMEMO_LEX_SET (i-1, - memoize (CAR (exps), new_env)), - body_exps); - - seq = memoize (body, new_env); - for (; scm_is_pair (body_exps); body_exps = CDR (body_exps)) - seq = MAKMEMO_SEQ (CAR (body_exps), seq); - - return MAKMEMO_LET (undefs, seq); + 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 MAKMEMO_LET (undefs, body_exps); } else { - SCM sets = SCM_EOL, inits = SCM_EOL, set_seq; - for (; scm_is_pair (exps); exps = CDR (exps), i--) + SCM sets = SCM_BOOL_F, inits = scm_c_make_vector (nvars, SCM_BOOL_F); + for (i = nvars - 1; i >= 0; i--) { - sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars, - MAKMEMO_LEX_REF (i-1)), - sets); - inits = scm_cons (memoize (CAR (exps), new_env), inits); + 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); } - inits = scm_reverse_x (inits, SCM_UNDEFINED); - sets = scm_reverse_x (sets, SCM_UNDEFINED); - if (scm_is_null (sets)) + if (scm_is_false (sets)) return memoize (body, env); - for (set_seq = CAR (sets), sets = CDR (sets); scm_is_pair (sets); - sets = CDR (sets)) - set_seq = MAKMEMO_SEQ (CAR (sets), set_seq); - return MAKMEMO_LET (undefs, - MAKMEMO_SEQ (MAKMEMO_LET (inits, set_seq), + MAKMEMO_SEQ (MAKMEMO_LET (inits, sets), memoize (body, new_env))); } } @@ -577,26 +581,22 @@ unmemoize_exprs (SCM exprs) static SCM unmemoize_bindings (SCM inits) { - SCM ret, tail; - if (scm_is_null (inits)) - return SCM_EOL; - ret = scm_list_1 (scm_list_2 (sym_placeholder, unmemoize (CAR (inits)))); - tail = ret; - for (inits = CDR (inits); !scm_is_null (inits); inits = CDR (inits)) - { - SCM_SETCDR (tail, scm_list_1 (scm_list_2 (sym_placeholder, - unmemoize (CAR (inits))))); - tail = CDR (tail); - } + SCM ret = SCM_EOL; + int n = scm_c_vector_length (inits); + + while (n--) + ret = scm_cons (unmemoize (scm_c_vector_ref (inits, n)), ret); + return ret; } static SCM unmemoize_lexical (SCM n) { - char buf[16]; - buf[15] = 0; - snprintf (buf, 15, "<%u>", scm_to_uint32 (n)); + char buf[32]; + buf[31] = 0; + snprintf (buf, 31, "<%u,%u>", scm_to_uint32 (CAR (n)), + scm_to_uint32 (CDR (n))); return scm_from_utf8_symbol (buf); } diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm index 1270732d7..1d027073b 100644 --- a/module/ice-9/eval.scm +++ b/module/ice-9/eval.scm @@ -57,6 +57,42 @@ (and (current-module) the-root-module) env))))) + (define-syntax env-toplevel + (syntax-rules () + ((_ env) + (let lp ((e env)) + (if (vector? e) + (lp (vector-ref e 0)) + e))))) + + (define-syntax make-env + (syntax-rules () + ((_ n init next) + (let ((v (make-vector (1+ n) init))) + (vector-set! v 0 next) + v)))) + + (define-syntax make-env* + (syntax-rules () + ((_ next init ...) + (vector next init ...)))) + + (define-syntax env-ref + (syntax-rules () + ((_ env depth width) + (let lp ((e env) (d depth)) + (if (zero? d) + (vector-ref e (1+ width)) + (lp (vector-ref e 0) (1- d))))))) + + (define-syntax env-set! + (syntax-rules () + ((_ env depth width val) + (let lp ((e env) (d depth)) + (if (zero? d) + (vector-set! e (1+ width) val) + (lp (vector-ref e 0) (1- d))))))) + ;; Fast case for procedures with fixed arities. (define-syntax make-fixed-closure (lambda (x) @@ -79,28 +115,32 @@ #`((#,nreq) (lambda (#,@formals) (eval body - (cons* #,@(reverse formals) env)))))) + (make-env* env #,@formals)))))) (iota *max-static-argument-count*)) (else #,(let ((formals (make-formals *max-static-argument-count*))) #`(lambda (#,@formals . more) - (let lp ((new-env (cons* #,@(reverse formals) env)) - (nreq (- nreq #,*max-static-argument-count*)) - (args more)) - (if (zero? nreq) + (let ((env (make-env nreq #f env))) + #,@(map (lambda (formal n) + #`(env-set! env 0 #,n #,formal)) + formals (iota (length formals))) + (let lp ((i #,*max-static-argument-count*) + (args more)) + (cond + ((= i nreq) (eval body (if (null? args) - new-env + env (scm-error 'wrong-number-of-args "eval" "Wrong number of arguments" - '() #f))) - (if (null? args) - (scm-error 'wrong-number-of-args - "eval" "Wrong number of arguments" - '() #f) - (lp (cons (car args) new-env) - (1- nreq) - (cdr args))))))))))))) + '() #f)))) + ((null? args) + (scm-error 'wrong-number-of-args + "eval" "Wrong number of arguments" + '() #f)) + (else + (env-set! env 0 i (car args)) + (lp (1+ i) (cdr args)))))))))))))) ;; Fast case for procedures with fixed arities and a rest argument. (define-syntax make-rest-closure @@ -124,23 +164,28 @@ #`((#,nreq) (lambda (#,@formals . rest) (eval body - (cons* rest #,@(reverse formals) env)))))) + (make-env* env #,@formals rest)))))) (iota *max-static-argument-count*)) (else #,(let ((formals (make-formals *max-static-argument-count*))) #`(lambda (#,@formals . more) - (let lp ((new-env (cons* #,@(reverse formals) env)) - (nreq (- nreq #,*max-static-argument-count*)) - (args more)) - (if (zero? nreq) - (eval body (cons args new-env)) - (if (null? args) - (scm-error 'wrong-number-of-args - "eval" "Wrong number of arguments" - '() #f) - (lp (cons (car args) new-env) - (1- nreq) - (cdr args))))))))))))) + (let ((env (make-env (1+ nreq) #f env))) + #,@(map (lambda (formal n) + #`(env-set! env 0 #,n #,formal)) + formals (iota (length formals))) + (let lp ((i #,*max-static-argument-count*) + (args more)) + (cond + ((= i nreq) + (env-set! env 0 nreq args) + (eval body env)) + ((null? args) + (scm-error 'wrong-number-of-args + "eval" "Wrong number of arguments" + '() #f)) + (else + (env-set! env 0 i (car args)) + (lp (1+ i) (cdr args)))))))))))))) (define-syntax call (lambda (x) @@ -301,125 +346,110 @@ proc) (set-procedure-arity! (lambda %args - (let lp ((env env) - (nreq* nreq) - (args %args)) - (if (> nreq* 0) - ;; First, bind required arguments. - (if (null? args) - (if alt - (apply alt-proc %args) - (scm-error 'wrong-number-of-args - "eval" "Wrong number of arguments" - '() #f)) - (lp (cons (car args) env) - (1- nreq*) - (cdr args))) - ;; Move on to optional arguments. - (if (not kw) - ;; Without keywords, bind optionals from arguments. - (let lp ((env env) - (nopt nopt) - (args args) - (inits inits)) - (if (zero? nopt) - (if rest? - (eval body (cons args env)) - (if (null? args) - (eval body env) - (if alt - (apply alt-proc %args) - (scm-error 'wrong-number-of-args - "eval" "Wrong number of arguments" - '() #f)))) - (if (null? args) - (lp (cons (eval (car inits) env) env) - (1- nopt) args (cdr inits)) - (lp (cons (car args) env) - (1- nopt) (cdr args) (cdr inits))))) - (let lp ((env env) - (nopt* nopt) - (args args) - (inits inits)) + (define (npositional args) + (let lp ((n 0) (args args)) + (if (or (null? args) + (and (>= n nreq) (keyword? (car args)))) + n + (lp (1+ n) (cdr args))))) + (let ((nargs (length %args))) + (cond + ((or (< nargs nreq) + (and (not kw) (not rest?) (> nargs (+ nreq nopt))) + (and kw (not rest?) (> (npositional %args) (+ nreq nopt)))) + (if alt + (apply alt-proc %args) + ((scm-error 'wrong-number-of-args + "eval" "Wrong number of arguments" + '() #f)))) + (else + (let* ((nvals (+ nreq (if rest? 1 0) (length inits))) + (env (make-env nvals unbound-arg env))) + (let lp ((i 0) (args %args)) + (cond + ((< i nreq) + ;; Bind required arguments. + (env-set! env 0 i (car args)) + (lp (1+ i) (cdr args))) + ((not kw) + ;; Optional args (possibly), but no keyword args. + (let lp ((i i) (args args) (inits inits)) (cond - ;; With keywords, we stop binding optionals at the - ;; first keyword. - ((> nopt* 0) - (if (or (null? args) (keyword? (car args))) - (lp (cons (eval (car inits) env) env) - (1- nopt*) args (cdr inits)) - (lp (cons (car args) env) - (1- nopt*) (cdr args) (cdr inits)))) - ;; Finished with optionals. - ((and alt (pair? args) (not (keyword? (car args))) - (not rest?)) - ;; Too many positional args, no #:rest arg, - ;; and we have an alternate. - (apply alt-proc %args)) + ((< i (+ nreq nopt)) + (cond + ((< i nargs) + (env-set! env 0 i (car args)) + (lp (1+ i) (cdr args) (cdr inits))) + (else + (env-set! env 0 i (eval (car inits) env)) + (lp (1+ i) args (cdr inits))))) (else - (let* ((aok (car kw)) - (kw (cdr kw)) - (kw-base (+ nopt nreq (if rest? 1 0))) - (imax (let lp ((imax (1- kw-base)) (kw kw)) - (if (null? kw) - imax - (lp (max (cdar kw) imax) - (cdr kw))))) - ;; Fill in kwargs with "undefined" vals. - (env (let lp ((i kw-base) - ;; Also, here we bind the rest - ;; arg, if any. - (env (if rest? - (cons args env) - env))) - (if (<= i imax) - (lp (1+ i) (cons unbound-arg env)) - env)))) + (when rest? + (env-set! env 0 i args)) + (eval body env))))) + (else + ;; Optional args. As before, but stop at the first + ;; keyword. + (let lp ((i i) (args args) (inits inits)) + (cond + ((< i (+ nreq nopt)) + (cond + ((and (< i nargs) (not (keyword? (car args)))) + (env-set! env 0 i (car args)) + (lp (1+ i) (cdr args) (cdr inits))) + (else + (env-set! env 0 i (eval (car inits) env)) + (lp (1+ i) args (cdr inits))))) + (else + (when rest? + (env-set! env 0 i args)) + (let ((aok (car kw)) + (kw (cdr kw)) + (kw-base (if rest? (1+ i) i))) ;; Now scan args for keywords. (let lp ((args args)) - (if (and (pair? args) (pair? (cdr args)) - (keyword? (car args))) - (let ((kw-pair (assq (car args) kw)) - (v (cadr args))) - (if kw-pair - ;; Found a known keyword; set its value. - (list-set! env - (- imax (cdr kw-pair)) v) - ;; Unknown keyword. - (if (not aok) - (scm-error - 'keyword-argument-error - "eval" "Unrecognized keyword" - '() (list (car args))))) - (lp (cddr args))) - (if (pair? args) - (if rest? - ;; Be lenient parsing rest args. - (lp (cdr args)) - (scm-error 'keyword-argument-error - "eval" "Invalid keyword" - '() (list (car args)))) - ;; Finished parsing keywords. Fill in - ;; uninitialized kwargs by evalling init - ;; expressions in their appropriate - ;; environment. - (let lp ((i (- imax kw-base)) - (inits inits)) - (if (pair? inits) - (let ((tail (list-tail env i))) - (if (eq? (car tail) unbound-arg) - (set-car! tail - (eval (car inits) - (cdr tail)))) - (lp (1- i) (cdr inits))) - ;; Finally, eval the body. - (eval body env)))))))))))))))) + (cond + ((and (pair? args) (pair? (cdr args)) + (keyword? (car args))) + (let ((kw-pair (assq (car args) kw)) + (v (cadr args))) + (if kw-pair + ;; Found a known keyword; set its value. + (env-set! env 0 (cdr kw-pair) v) + ;; Unknown keyword. + (if (not aok) + ((scm-error + 'keyword-argument-error + "eval" "Unrecognized keyword" + '() (list (car args)))))) + (lp (cddr args)))) + ((pair? args) + (if rest? + ;; Be lenient parsing rest args. + (lp (cdr args)) + ((scm-error 'keyword-argument-error + "eval" "Invalid keyword" + '() (list (car args)))))) + (else + ;; Finished parsing keywords. Fill in + ;; uninitialized kwargs by evalling init + ;; expressions in their appropriate + ;; environment. + (let lp ((i kw-base) (inits inits)) + (cond + ((pair? inits) + (when (eq? (env-ref env 0 i) unbound-arg) + (env-set! env 0 i (eval (car inits) env))) + (lp (1+ i) (cdr inits))) + (else + ;; Finally, eval the body. + (eval body env))))))))))))))))))))) ;; The "engine". EXP is a memoized expression. (define (eval exp env) (memoized-expression-case exp - (('lexical-ref n) - (list-ref env n)) + (('lexical-ref (depth . width)) + (env-ref env depth width)) (('call (f nargs . args)) (let ((proc (eval f env))) @@ -430,9 +460,7 @@ (if (variable? var-or-sym) var-or-sym (memoize-variable-access! exp - (capture-env (if (pair? env) - (cdr (last-pair env)) - env)))))) + (capture-env (env-toplevel env)))))) (('if (test consequent . alternate)) (if (eval test env) @@ -443,11 +471,13 @@ x) (('let (inits . body)) - (let lp ((inits inits) (new-env (capture-env env))) - (if (null? inits) - (eval body new-env) - (lp (cdr inits) - (cons (eval (car inits) env) new-env))))) + (let* ((width (vector-length inits)) + (new-env (make-env width #f (capture-env env)))) + (let lp ((i 0)) + (when (< i width) + (env-set! new-env 0 i (eval (vector-ref inits i) env)) + (lp (1+ i)))) + (eval body new-env))) (('lambda (body docstring nreq . tail)) (let ((proc @@ -466,9 +496,8 @@ (eval head env) (eval tail env))) - (('lexical-set! (n . x)) - (let ((val (eval x env))) - (list-set! env n val))) + (('lexical-set! ((depth . width) . x)) + (env-set! env depth width (eval x env))) (('call-with-values (producer . consumer)) (call-with-values (eval producer env) @@ -495,9 +524,7 @@ (if (variable? var-or-sym) var-or-sym (memoize-variable-access! exp - (capture-env (if (pair? env) - (cdr (last-pair env)) - env)))) + (capture-env (env-toplevel env)))) (eval x env))) (('call-with-prompt (tag thunk . handler)) |