X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/521c542199afa4f199746d5bbffc18a988cb30bc..e87f059319e40b582d5ee8fd815876550f1148b9:/libguile/eval.c diff --git a/libguile/eval.c b/libguile/eval.c index f5e1524c7..72f15314f 100644 --- a/libguile/eval.c +++ b/libguile/eval.c @@ -1,5 +1,5 @@ /* 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 @@ -116,13 +116,13 @@ static scm_t_bits scm_tc16_boot_closure; #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)) \ @@ -132,7 +132,8 @@ static scm_t_bits scm_tc16_boot_closure; { \ 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); \ } \ } \ @@ -153,15 +154,49 @@ 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)) -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, @@ -203,18 +238,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,11 +247,9 @@ 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); @@ -245,24 +266,47 @@ 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_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. */ @@ -279,7 +323,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. */ @@ -301,7 +345,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: @@ -315,7 +359,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 @@ -325,83 +369,62 @@ 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); - 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. */ @@ -409,22 +432,25 @@ eval (SCM x, SCM env) 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; } @@ -446,41 +472,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 @@ -488,7 +514,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 @@ -496,7 +522,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 @@ -504,7 +530,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 @@ -512,14 +538,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, ...) @@ -539,7 +561,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 @@ -548,53 +570,74 @@ 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); + 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))); } @@ -603,15 +646,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); } @@ -656,24 +699,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 @@ -682,15 +719,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; } @@ -698,20 +738,24 @@ 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; - 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) @@ -734,25 +778,41 @@ 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) + 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 { @@ -761,45 +821,22 @@ 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); - - 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)) @@ -810,10 +847,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; } @@ -822,15 +856,6 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, } 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))); - } } } @@ -845,32 +870,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; }