diff options
Diffstat (limited to 'libguile/eval.c')
-rw-r--r-- | libguile/eval.c | 492 |
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, + ®isters); + + 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; } |