/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001,2002,2003,2004,
- * 2005,2006,2007,2008,2009,2010,2011,2012,2013
+ * 2005,2006,2007,2008,2009,2010,2011,2012,2013,2014
* Free Software Foundation, Inc.
*
* This library is free software; you can redistribute it and/or
#define BOOT_CLOSURE_IS_REST(x) scm_is_null (SCM_CDR (CDDDR (BOOT_CLOSURE_CODE (x))))
/* NB: One may only call the following accessors if the closure is not REST. */
#define BOOT_CLOSURE_IS_FULL(x) (1)
-#define BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,inits,alt) \
+#define BOOT_CLOSURE_PARSE_FULL(fu_,body,nargs,rest,nopt,kw,ninits,unbound,alt) \
do { SCM fu = fu_; \
body = CAR (fu); fu = CDDR (fu); \
\
rest = kw = alt = SCM_BOOL_F; \
- inits = SCM_EOL; \
- nopt = 0; \
+ unbound = SCM_BOOL_F; \
+ nopt = ninits = 0; \
\
nreq = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
if (scm_is_pair (fu)) \
{ \
nopt = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
kw = CAR (fu); fu = CDR (fu); \
- inits = CAR (fu); fu = CDR (fu); \
+ ninits = SCM_I_INUM (CAR (fu)); fu = CDR (fu); \
+ unbound = CAR (fu); fu = CDR (fu); \
alt = CAR (fu); \
} \
} \
#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))
-SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable");
+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 void error_used_before_defined (void)
+static SCM
+env_tail (SCM env)
{
- scm_error (scm_unbound_variable_key, NULL,
- "Variable used before given a value", SCM_EOL, SCM_BOOL_F);
+ 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);
+}
+
+
static void error_invalid_keyword (SCM proc, SCM obj)
{
scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc,
}
#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)
{
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_SEQ:
eval (CAR (mx), 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_CAPTURE_ENV:
+ {
+ SCM locs = CAR (mx);
+ SCM new_env;
+ int i;
+
+ new_env = make_env (VECTOR_LENGTH (locs), SCM_BOOL_F, env);
+ for (i = 0; i < VECTOR_LENGTH (locs); i++)
+ {
+ SCM loc = VECTOR_REF (locs, i);
+ int depth, width;
+
+ depth = SCM_I_INUM (CAR (loc));
+ width = SCM_I_INUM (CDR (loc));
+ env_set (new_env, 0, i, env_ref (env, depth, width));
+ }
+
+ env = new_env;
+ x = CDR (mx);
+ goto loop;
+ }
case SCM_M_QUOTE:
return mx;
- case SCM_M_DEFINE:
- scm_define (CAR (mx), EVAL1 (CDR (mx), env));
- return SCM_UNSPECIFIED;
+ case SCM_M_CAPTURE_MODULE:
+ return eval (mx, scm_current_module ());
case SCM_M_APPLY:
/* Evaluate the procedure to be applied. */
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. */
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:
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
case SCM_M_LEXICAL_REF:
{
- int n;
- SCM ret;
- for (n = SCM_I_INUM (mx); n; n--)
- env = CDR (env);
- ret = CAR (env);
- if (SCM_UNLIKELY (SCM_UNBNDP (ret)))
- /* we don't know what variable, though, because we don't have its
- name */
- error_used_before_defined ();
- return ret;
+ SCM pos;
+ int depth, width;
+
+ pos = mx;
+ depth = SCM_I_INUM (CAR (pos));
+ width = SCM_I_INUM (CDR (pos));
+
+ return env_ref (env, depth, width);
}
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;
}
- case SCM_M_TOPLEVEL_REF:
- if (SCM_VARIABLEP (mx))
- 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)));
- }
+ case SCM_M_BOX_REF:
+ {
+ SCM box = mx;
- case SCM_M_TOPLEVEL_SET:
+ return scm_variable_ref (EVAL1 (box, env));
+ }
+
+ case SCM_M_BOX_SET:
{
- SCM var = CAR (mx);
- SCM val = EVAL1 (CDR (mx), env);
- if (SCM_VARIABLEP (var))
- {
- SCM_VARIABLE_SET (var, val);
- return SCM_UNSPECIFIED;
- }
- else
- {
- while (scm_is_pair (env))
- env = CDR (env);
- SCM_VARIABLE_SET
- (scm_memoize_variable_access_x (x, CAPTURE_ENV (env)),
- val);
- return SCM_UNSPECIFIED;
- }
+ SCM box = CAR (mx), val = CDR (mx);
+
+ return scm_variable_set_x (EVAL1 (box, env), EVAL1 (val, env));
}
- case SCM_M_MODULE_REF:
+ case SCM_M_RESOLVE:
if (SCM_VARIABLEP (mx))
- return SCM_VARIABLE_REF (mx);
- else
- return SCM_VARIABLE_REF
- (scm_memoize_variable_access_x (x, SCM_BOOL_F));
-
- case SCM_M_MODULE_SET:
- if (SCM_VARIABLEP (CDR (mx)))
- {
- SCM_VARIABLE_SET (CDR (mx), EVAL1 (CAR (mx), env));
- return SCM_UNSPECIFIED;
- }
+ return mx;
else
{
- SCM_VARIABLE_SET
- (scm_memoize_variable_access_x (x, SCM_BOOL_F),
- EVAL1 (CAR (mx), env));
- return SCM_UNSPECIFIED;
+ SCM var;
+
+ var = scm_sys_resolve_variable (mx, env_tail (env));
+ scm_set_cdr_x (x, var);
+
+ return var;
}
case SCM_M_CALL_WITH_PROMPT:
{
- SCM vm, k, res;
+ 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. */
k = EVAL1 (CAR (mx), env);
handler = EVAL1 (CDDR (mx), env);
- vm = scm_the_vm ();
+ 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_ESCAPE_ONLY
+ | SCM_F_DYNSTACK_PROMPT_PUSH_NARGS,
k,
- SCM_VM_DATA (vm)->fp,
- SCM_VM_DATA (vm)->sp,
- SCM_VM_DATA (vm)->ip,
+ vp->fp - vp->stack_base,
+ vp->sp - vp->stack_base,
+ vp->ip,
®isters);
if (SCM_I_SETJMP (registers))
{
/* The prompt exited nonlocally. */
+ scm_gc_after_nonlocal_exit ();
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;
}
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
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
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
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
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, ...)
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
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);
+ return scm_apply_0 (proc, scm_cons (arg1, scm_cons2 (arg2, arg3, args)));
}
+static SCM map_var, for_each_var;
+
+static void init_map_var (void)
+{
+ map_var = scm_private_variable (scm_the_root_module (),
+ scm_from_latin1_symbol ("map"));
+}
+
+static void init_for_each_var (void)
+{
+ for_each_var = scm_private_variable (scm_the_root_module (),
+ scm_from_latin1_symbol ("for-each"));
+}
SCM
scm_map (SCM proc, SCM arg1, SCM args)
{
- static SCM var = SCM_BOOL_F;
-
- if (scm_is_false (var))
- var = scm_private_variable (scm_the_root_module (),
- scm_from_latin1_symbol ("map"));
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_i_pthread_once (&once, init_map_var);
- return scm_apply (scm_variable_ref (var),
- scm_cons (proc, scm_cons (arg1, args)), SCM_EOL);
+ return scm_apply_0 (scm_variable_ref (map_var),
+ scm_cons (proc, scm_cons (arg1, args)));
}
SCM
scm_for_each (SCM proc, SCM arg1, SCM args)
{
- static SCM var = SCM_BOOL_F;
-
- if (scm_is_false (var))
- var = scm_private_variable (scm_the_root_module (),
- scm_from_latin1_symbol ("for-each"));
+ static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT;
+ scm_i_pthread_once (&once, init_for_each_var);
- return scm_apply (scm_variable_ref (var),
- scm_cons (proc, scm_cons (arg1, args)), SCM_EOL);
+ return scm_apply_0 (scm_variable_ref (for_each_var),
+ scm_cons (proc, scm_cons (arg1, args)));
}
{
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);
}
/* 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
{
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;
- SCM body, rest, kw, inits, alt;
+ int i, argc, nreq, nopt, ninits, nenv;
+ SCM body, rest, kw, unbound, alt;
SCM mx = BOOT_CLOSURE_CODE (proc);
loop:
- BOOT_CLOSURE_PARSE_FULL (mx, body, nargs, rest, nopt, kw, inits, alt);
+ BOOT_CLOSURE_PARSE_FULL (mx, body, nargs, rest, nopt, kw,
+ ninits, unbound, alt);
argc = scm_ilength (args);
if (argc < nreq)
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) + ninits;
+ env = make_env (nenv, unbound, 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);
- }
-
- for (; i < nreq + nopt; i++, inits = CDR (inits))
- env = scm_cons (EVAL1 (CAR (inits), env), env);
-
+ for (; i < argc && i < nreq + nopt; i++, args = CDR (args))
+ env_set (env, 0, i, CAR (args));
if (scm_is_true (rest))
- env = scm_cons (args, env);
+ env_set (env, 0, nreq + nopt, 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);
-
- for (; i < nreq + nopt; i++, inits = CDR (inits))
- env = scm_cons (EVAL1 (CAR (inits), env), env);
-
+ i++, args = CDR (args))
+ env_set (env, 0, i, CAR (args));
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, nreq + nopt, 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;
}
}
if (scm_is_pair (args) && scm_is_false (rest))
error_invalid_keyword (proc, CAR (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)));
- }
}
}
{
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;
}
HCoop / bpt / guile.git / blobdiff