X-Git-Url: http://git.hcoop.net/bpt/guile.git/blobdiff_plain/091dd0cc58ea54c71bdef2e5804cf21095b342d5..e87f059319e40b582d5ee8fd815876550f1148b9:/libguile/eval.c diff --git a/libguile/eval.c b/libguile/eval.c index 3e828a178..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); \ } \ } \ @@ -196,14 +197,6 @@ env_set (SCM env, int depth, int width, SCM val) } -SCM_SYMBOL (scm_unbound_variable_key, "unbound-variable"); - -static void error_used_before_defined (void) -{ - scm_error (scm_unbound_variable_key, NULL, - "Variable used before given a value", SCM_EOL, SCM_BOOL_F); -} - static void error_invalid_keyword (SCM proc, SCM obj) { scm_error_scm (scm_from_latin1_symbol ("keyword-argument-error"), proc, @@ -287,13 +280,31 @@ eval (SCM x, SCM env) case SCM_M_LAMBDA: 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 ()); @@ -358,20 +369,14 @@ eval (SCM x, SCM env) case SCM_M_LEXICAL_REF: { - SCM pos, ret; + SCM pos; 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 */ - error_used_before_defined (); - return ret; + return env_ref (env, depth, width); } case SCM_M_LEXICAL_SET: @@ -389,51 +394,31 @@ eval (SCM x, SCM env) return SCM_UNSPECIFIED; } - case SCM_M_TOPLEVEL_REF: - if (SCM_VARIABLEP (mx)) - return SCM_VARIABLE_REF (mx); - else - { - env = env_tail (env); - return SCM_VARIABLE_REF (scm_memoize_variable_access_x (x, env)); - } + case SCM_M_BOX_REF: + { + SCM box = mx; + + return scm_variable_ref (EVAL1 (box, env)); + } - case SCM_M_TOPLEVEL_SET: + 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 - { - env = env_tail (env); - SCM_VARIABLE_SET (scm_memoize_variable_access_x (x, 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: @@ -462,6 +447,7 @@ eval (SCM x, SCM env) if (SCM_I_SETJMP (registers)) { /* The prompt exited nonlocally. */ + scm_gc_after_nonlocal_exit (); proc = handler; vp = scm_the_vm (); args = scm_i_prompt_pop_abort_args_x (vp); @@ -620,30 +606,37 @@ scm_apply_3 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM args) 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; + static scm_i_pthread_once_t once = SCM_I_PTHREAD_ONCE_INIT; + scm_i_pthread_once (&once, init_map_var); - if (scm_is_false (var)) - var = scm_private_variable (scm_the_root_module (), - scm_from_latin1_symbol ("map")); - - return scm_apply_0 (scm_variable_ref (var), + 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_0 (scm_variable_ref (var), + return scm_apply_0 (scm_variable_ref (for_each_var), scm_cons (proc, scm_cons (arg1, args))); } @@ -756,12 +749,13 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, } else { - int i, argc, nreq, nopt, nenv; - 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) @@ -806,8 +800,8 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, } /* 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); + 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_set (env, 0, i, CAR (args)); @@ -815,15 +809,10 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, if (scm_is_false (kw)) { /* Optional args (possibly), but no keyword args. */ - for (; i < argc && i < nreq + nopt; - i++, args = CDR (args), inits = CDR (inits)) + for (; i < argc && i < nreq + nopt; i++, args = CDR (args)) env_set (env, 0, i, CAR (args)); - - for (; i < nreq + nopt; i++, inits = CDR (inits)) - env_set (env, 0, i, EVAL1 (CAR (inits), env)); - if (scm_is_true (rest)) - env_set (env, 0, i++, args); + env_set (env, 0, nreq + nopt, args); } else { @@ -834,18 +823,13 @@ prepare_boot_closure_env_for_apply (SCM proc, SCM args, /* 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)) + i++, args = CDR (args)) env_set (env, 0, i, CAR (args)); - - for (; i < nreq + nopt; i++, inits = CDR (inits)) - env_set (env, 0, i, EVAL1 (CAR (inits), env)); - if (scm_is_true (rest)) - env_set (env, 0, i++, args); + env_set (env, 0, nreq + nopt, args); /* Parse keyword args. */ { - int kw_start_idx = i; SCM walk; if (scm_is_pair (args) && scm_is_pair (CDR (args))) @@ -872,20 +856,9 @@ 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 = 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; }