summaryrefslogtreecommitdiff
path: root/libguile/eval.c
diff options
context:
space:
mode:
Diffstat (limited to 'libguile/eval.c')
-rw-r--r--libguile/eval.c492
1 files changed, 236 insertions, 256 deletions
diff --git a/libguile/eval.c b/libguile/eval.c
index 6047d6d75..3e828a178 100644
--- a/libguile/eval.c
+++ b/libguile/eval.c
@@ -1,4 +1,5 @@
-/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,2005,2006,2007,2008,2009,2010,2011,2013
+/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,
+ * 2005,2006,2007,2008,2009,2010,2011,2012,2013
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
@@ -39,7 +40,6 @@
#include "libguile/eq.h"
#include "libguile/expand.h"
#include "libguile/feature.h"
-#include "libguile/fluids.h"
#include "libguile/goops.h"
#include "libguile/hash.h"
#include "libguile/hashtab.h"
@@ -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");
@@ -203,18 +245,6 @@ truncate_values (SCM x)
}
#define EVAL1(x, env) (truncate_values (eval ((x), (env))))
-/* the environment:
- (VAL ... . MOD)
- If MOD is #f, it means the environment was captured before modules were
- booted.
- If MOD is the literal value '(), we are evaluating at the top level, and so
- should track changes to the current module. You have to be careful in this
- case, because further lexical contours should capture the current module.
-*/
-#define CAPTURE_ENV(env) \
- (scm_is_null (env) ? scm_current_module () : \
- (scm_is_false (env) ? scm_the_root_module () : env))
-
static SCM
eval (SCM x, SCM env)
{
@@ -224,16 +254,13 @@ eval (SCM x, SCM env)
loop:
SCM_TICK;
- if (!SCM_MEMOIZED_P (x))
- abort ();
mx = SCM_MEMOIZED_ARGS (x);
- switch (SCM_MEMOIZED_TAG (x))
+ switch (SCM_I_INUM (SCM_CAR (x)))
{
- case SCM_M_BEGIN:
- for (; !scm_is_null (CDR (mx)); mx = CDR (mx))
- eval (CAR (mx), env);
- x = CAR (mx);
+ case SCM_M_SEQ:
+ eval (CAR (mx), env);
+ x = CDR (mx);
goto loop;
case SCM_M_IF:
@@ -246,17 +273,19 @@ 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, 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_LAMBDA:
- RETURN_BOOT_CLOSURE (mx, CAPTURE_ENV (env));
+ RETURN_BOOT_CLOSURE (mx, env);
case SCM_M_QUOTE:
return mx;
@@ -265,41 +294,8 @@ eval (SCM x, SCM env)
scm_define (CAR (mx), EVAL1 (CDR (mx), env));
return SCM_UNSPECIFIED;
- case SCM_M_DYNWIND:
- {
- SCM in, out, res, old_winds;
- in = EVAL1 (CAR (mx), env);
- out = EVAL1 (CDDR (mx), env);
- scm_call_0 (in);
- old_winds = scm_i_dynwinds ();
- scm_i_set_dynwinds (scm_acons (in, out, old_winds));
- res = eval (CADR (mx), env);
- scm_i_set_dynwinds (old_winds);
- scm_call_0 (out);
- return res;
- }
-
- case SCM_M_WITH_FLUIDS:
- {
- long i, len;
- SCM *fluidv, *valuesv, walk, wf, res;
- len = scm_ilength (CAR (mx));
- fluidv = alloca (sizeof (SCM)*len);
- for (i = 0, walk = CAR (mx); i < len; i++, walk = CDR (walk))
- fluidv[i] = EVAL1 (CAR (walk), env);
- valuesv = alloca (sizeof (SCM)*len);
- for (i = 0, walk = CADR (mx); i < len; i++, walk = CDR (walk))
- valuesv[i] = EVAL1 (CAR (walk), env);
-
- wf = scm_i_make_with_fluids (len, fluidv, valuesv);
- scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
- scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ()));
- res = eval (CDDR (mx), env);
- scm_i_swap_with_fluids (wf, SCM_I_CURRENT_THREAD->dynamic_state);
- scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));
-
- return res;
- }
+ case SCM_M_CAPTURE_MODULE:
+ return eval (mx, scm_current_module ());
case SCM_M_APPLY:
/* Evaluate the procedure to be applied. */
@@ -316,7 +312,7 @@ eval (SCM x, SCM env)
goto loop;
}
else
- return scm_call_with_vm (scm_the_vm (), proc, args);
+ return scm_apply_0 (proc, args);
case SCM_M_CALL:
/* Evaluate the procedure to be applied. */
@@ -338,7 +334,7 @@ eval (SCM x, SCM env)
for (i = 0; i < argc; i++, mx = CDR (mx))
argv[i] = EVAL1 (CAR (mx), env);
- return scm_c_vm_run (scm_the_vm (), proc, argv, argc);
+ return scm_call_n (proc, argv, argc);
}
case SCM_M_CONT:
@@ -352,7 +348,7 @@ eval (SCM x, SCM env)
producer = EVAL1 (CAR (mx), env);
/* `proc' is the consumer. */
proc = EVAL1 (CDR (mx), env);
- v = scm_call_with_vm (scm_the_vm (), producer, SCM_EOL);
+ v = scm_call_0 (producer);
if (SCM_VALUESP (v))
args = scm_struct_ref (v, SCM_INUM0);
else
@@ -362,11 +358,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 */
@@ -376,11 +376,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;
}
@@ -389,10 +394,8 @@ eval (SCM x, SCM env)
return SCM_VARIABLE_REF (mx);
else
{
- while (scm_is_pair (env))
- env = CDR (env);
- return SCM_VARIABLE_REF
- (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)));
+ env = env_tail (env);
+ return SCM_VARIABLE_REF (scm_memoize_variable_access_x (x, env));
}
case SCM_M_TOPLEVEL_SET:
@@ -406,11 +409,8 @@ eval (SCM x, SCM env)
}
else
{
- while (scm_is_pair (env))
- env = CDR (env);
- SCM_VARIABLE_SET
- (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)),
- val);
+ env = env_tail (env);
+ SCM_VARIABLE_SET (scm_memoize_variable_access_x (x, env), val);
return SCM_UNSPECIFIED;
}
}
@@ -436,31 +436,40 @@ eval (SCM x, SCM env)
return SCM_UNSPECIFIED;
}
- case SCM_M_PROMPT:
+ case SCM_M_CALL_WITH_PROMPT:
{
- SCM vm, res;
- /* We need the prompt and handler values after a longjmp case,
- so make sure they are volatile. */
- volatile SCM handler, prompt;
-
- vm = scm_the_vm ();
- prompt = scm_c_make_prompt (EVAL1 (CAR (mx), env),
- SCM_VM_DATA (vm)->fp,
- SCM_VM_DATA (vm)->sp, SCM_VM_DATA (vm)->ip,
- 0, -1, scm_i_dynwinds ());
+ struct scm_vm *vp;
+ SCM k, res;
+ scm_i_jmp_buf registers;
+ /* We need the handler after nonlocal return to the setjmp, so
+ make sure it is volatile. */
+ volatile SCM handler;
+
+ k = EVAL1 (CAR (mx), env);
handler = EVAL1 (CDDR (mx), env);
- scm_i_set_dynwinds (scm_cons (prompt, scm_i_dynwinds ()));
-
- if (SCM_PROMPT_SETJMP (prompt))
+ vp = scm_the_vm ();
+
+ /* Push the prompt onto the dynamic stack. */
+ scm_dynstack_push_prompt (&SCM_I_CURRENT_THREAD->dynstack,
+ SCM_F_DYNSTACK_PROMPT_ESCAPE_ONLY
+ | SCM_F_DYNSTACK_PROMPT_PUSH_NARGS,
+ k,
+ vp->fp - vp->stack_base,
+ vp->sp - vp->stack_base,
+ vp->ip,
+ &registers);
+
+ if (SCM_I_SETJMP (registers))
{
/* The prompt exited nonlocally. */
proc = handler;
- args = scm_i_prompt_pop_abort_args_x (scm_the_vm ());
+ vp = scm_the_vm ();
+ args = scm_i_prompt_pop_abort_args_x (vp);
goto apply_proc;
}
- res = eval (CADR (mx), env);
- scm_i_set_dynwinds (CDR (scm_i_dynwinds ()));
+ res = scm_call_0 (eval (CADR (mx), env));
+ scm_dynstack_pop (&SCM_I_CURRENT_THREAD->dynstack);
return res;
}
@@ -477,41 +486,41 @@ eval (SCM x, SCM env)
SCM
scm_call_0 (SCM proc)
{
- return scm_c_vm_run (scm_the_vm (), proc, NULL, 0);
+ return scm_call_n (proc, NULL, 0);
}
SCM
scm_call_1 (SCM proc, SCM arg1)
{
- return scm_c_vm_run (scm_the_vm (), proc, &arg1, 1);
+ return scm_call_n (proc, &arg1, 1);
}
SCM
scm_call_2 (SCM proc, SCM arg1, SCM arg2)
{
SCM args[] = { arg1, arg2 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 2);
+ return scm_call_n (proc, args, 2);
}
SCM
scm_call_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
{
SCM args[] = { arg1, arg2, arg3 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 3);
+ return scm_call_n (proc, args, 3);
}
SCM
scm_call_4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4)
{
SCM args[] = { arg1, arg2, arg3, arg4 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 4);
+ return scm_call_n (proc, args, 4);
}
SCM
scm_call_5 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5)
{
SCM args[] = { arg1, arg2, arg3, arg4, arg5 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 5);
+ return scm_call_n (proc, args, 5);
}
SCM
@@ -519,7 +528,7 @@ scm_call_6 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
SCM arg6)
{
SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 6);
+ return scm_call_n (proc, args, 6);
}
SCM
@@ -527,7 +536,7 @@ scm_call_7 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
SCM arg6, SCM arg7)
{
SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 7);
+ return scm_call_n (proc, args, 7);
}
SCM
@@ -535,7 +544,7 @@ scm_call_8 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
SCM arg6, SCM arg7, SCM arg8)
{
SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 8);
+ return scm_call_n (proc, args, 8);
}
SCM
@@ -543,14 +552,10 @@ scm_call_9 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5,
SCM arg6, SCM arg7, SCM arg8, SCM arg9)
{
SCM args[] = { arg1, arg2, arg3, arg4, arg5, arg6, arg7, arg8, arg9 };
- return scm_c_vm_run (scm_the_vm (), proc, args, 9);
+ return scm_call_n (proc, args, 9);
}
-SCM
-scm_call_n (SCM proc, SCM *argv, size_t nargs)
-{
- return scm_c_vm_run (scm_the_vm (), proc, argv, nargs);
-}
+/* scm_call_n defined in vm.c */
SCM
scm_call (SCM proc, ...)
@@ -570,7 +575,7 @@ scm_call (SCM proc, ...)
argv[i] = va_arg (argp, SCM);
va_end (argp);
- return scm_c_vm_run (scm_the_vm (), proc, argv, nargs);
+ return scm_call_n (proc, argv, nargs);
}
/* Simple procedure applies
@@ -579,68 +584,41 @@ scm_call (SCM proc, ...)
SCM
scm_apply_0 (SCM proc, SCM args)
{
- return scm_apply (proc, args, SCM_EOL);
+ SCM *argv;
+ int i, nargs;
+
+ nargs = scm_ilength (args);
+ if (SCM_UNLIKELY (nargs < 0))
+ scm_wrong_type_arg_msg ("apply", 2, args, "list");
+
+ /* FIXME: Use vm_builtin_apply instead of alloca. */
+ argv = alloca (nargs * sizeof(SCM));
+ for (i = 0; i < nargs; i++)
+ {
+ argv[i] = SCM_CAR (args);
+ args = SCM_CDR (args);
+ }
+
+ return scm_call_n (proc, argv, nargs);
}
SCM
scm_apply_1 (SCM proc, SCM arg1, SCM args)
{
- return scm_apply (proc, scm_cons (arg1, args), SCM_EOL);
+ return scm_apply_0 (proc, scm_cons (arg1, args));
}
SCM
scm_apply_2 (SCM proc, SCM arg1, SCM arg2, SCM args)
{
- return scm_apply (proc, scm_cons2 (arg1, arg2, args), SCM_EOL);
+ return scm_apply_0 (proc, scm_cons2 (arg1, arg2, args));
}
SCM
scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args)
{
- return scm_apply (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)),
- SCM_EOL);
-}
-
-/* This code processes the arguments to apply:
-
- (apply PROC ARG1 ... ARGS)
-
- Given a list (ARG1 ... ARGS), this function conses the ARG1
- ... arguments onto the front of ARGS, and returns the resulting
- list. Note that ARGS is a list; thus, the argument to this
- function is a list whose last element is a list.
-
- Apply calls this function, and applies PROC to the elements of the
- result. apply:nconc2last takes care of building the list of
- arguments, given (ARG1 ... ARGS).
-
- Rather than do new consing, apply:nconc2last destroys its argument.
- On that topic, this code came into my care with the following
- beautifully cryptic comment on that topic: "This will only screw
- you if you do (scm_apply scm_apply '( ... ))" If you know what
- they're referring to, send me a patch to this comment. */
-
-SCM_DEFINE (scm_nconc2last, "apply:nconc2last", 1, 0, 0,
- (SCM lst),
- "Given a list (@var{arg1} @dots{} @var{args}), this function\n"
- "conses the @var{arg1} @dots{} arguments onto the front of\n"
- "@var{args}, and returns the resulting list. Note that\n"
- "@var{args} is a list; thus, the argument to this function is\n"
- "a list whose last element is a list.\n"
- "Note: Rather than do new consing, @code{apply:nconc2last}\n"
- "destroys its argument, so use with care.")
-#define FUNC_NAME s_scm_nconc2last
-{
- SCM *lloc;
- SCM_VALIDATE_NONEMPTYLIST (1, lst);
- lloc = &lst;
- while (!scm_is_null (SCM_CDR (*lloc)))
- lloc = SCM_CDRLOC (*lloc);
- SCM_ASSERT (scm_ilength (SCM_CAR (*lloc)) >= 0, lst, SCM_ARG1, FUNC_NAME);
- *lloc = SCM_CAR (*lloc);
- return lst;
+ return scm_apply_0 (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)));
}
-#undef FUNC_NAME
SCM
@@ -652,8 +630,8 @@ scm_map (SCM proc, SCM arg1, SCM args)
var = scm_private_variable (scm_the_root_module (),
scm_from_latin1_symbol ("map"));
- return scm_apply (scm_variable_ref (var),
- scm_cons (proc, scm_cons (arg1, args)), SCM_EOL);
+ return scm_apply_0 (scm_variable_ref (var),
+ scm_cons (proc, scm_cons (arg1, args)));
}
SCM
@@ -665,8 +643,8 @@ scm_for_each (SCM proc, SCM arg1, SCM args)
var = scm_private_variable (scm_the_root_module (),
scm_from_latin1_symbol ("for-each"));
- return scm_apply (scm_variable_ref (var),
- scm_cons (proc, scm_cons (arg1, args)), SCM_EOL);
+ return scm_apply_0 (scm_variable_ref (var),
+ scm_cons (proc, scm_cons (arg1, args)));
}
@@ -675,15 +653,15 @@ scm_c_primitive_eval (SCM exp)
{
if (!SCM_EXPANDED_P (exp))
exp = scm_call_1 (scm_current_module_transformer (), exp);
- return eval (scm_memoize_expression (exp), SCM_EOL);
+ return eval (scm_memoize_expression (exp), SCM_BOOL_F);
}
static SCM var_primitive_eval;
SCM
scm_primitive_eval (SCM exp)
{
- return scm_c_vm_run (scm_the_vm (), scm_variable_ref (var_primitive_eval),
- &exp, 1);
+ return scm_call_n (scm_variable_ref (var_primitive_eval),
+ &exp, 1);
}
@@ -728,24 +706,18 @@ static SCM f_apply;
/* Apply a function to a list of arguments.
- This function is exported to the Scheme level as taking two
- required arguments and a tail argument, as if it were:
+ This function's interface is a bit wonly. It takes two required
+ arguments and a tail argument, as if it were:
+
(lambda (proc arg1 . args) ...)
- Thus, if you just have a list of arguments to pass to a procedure,
- pass the list as ARG1, and '() for ARGS. If you have some fixed
- args, pass the first as ARG1, then cons any remaining fixed args
- onto the front of your argument list, and pass that as ARGS. */
+
+ Usually you want to use scm_apply_0 or one of its cousins. */
SCM
scm_apply (SCM proc, SCM arg1, SCM args)
{
- /* Fix things up so that args contains all args. */
- if (scm_is_null (args))
- args = arg1;
- else
- args = scm_cons_star (arg1, args);
-
- return scm_call_with_vm (scm_the_vm (), proc, args);
+ return scm_apply_0 (proc,
+ scm_is_null (args) ? arg1 : scm_cons_star (arg1, args));
}
static void
@@ -754,15 +726,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;
}
@@ -770,15 +745,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);
@@ -806,25 +784,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
{
@@ -833,45 +832,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))
@@ -882,10 +863,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;
}
@@ -897,15 +875,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;
}
@@ -917,32 +897,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;
}
@@ -968,16 +948,16 @@ static int
boot_closure_print (SCM closure, SCM port, scm_print_state *pstate)
{
SCM args;
- scm_puts ("#<boot-closure ", port);
- scm_uintprint ((scm_t_bits)SCM2PTR (closure), 16, port);
- scm_putc (' ', port);
+ scm_puts_unlocked ("#<boot-closure ", port);
+ scm_uintprint (SCM_UNPACK (closure), 16, port);
+ scm_putc_unlocked (' ', port);
args = scm_make_list (scm_from_int (BOOT_CLOSURE_NUM_REQUIRED_ARGS (closure)),
scm_from_latin1_symbol ("_"));
if (!BOOT_CLOSURE_IS_FIXED (closure) && BOOT_CLOSURE_HAS_REST_ARGS (closure))
args = scm_cons_star (scm_from_latin1_symbol ("_"), args);
/* FIXME: optionals and rests */
scm_display (args, port);
- scm_putc ('>', port);
+ scm_putc_unlocked ('>', port);
return 1;
}