#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");
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;
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 */
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;
}
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)));
}
}
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);
{
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;
}
{
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);
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
{
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))
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;
}
/* 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;
}
{
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;
}
#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*");
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) \
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)))
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)));
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))
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));
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)));
}
}
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);
}
(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)
#`((#,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
#`((#,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)
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)))
(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)
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
(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)
(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))
HCoop / bpt / guile.git / commitdiff