From 438152be2bda0288e5d5e8c5b013077ac9512d86 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Fri, 21 Feb 2014 21:47:39 -0800 Subject: Implementing special variables with local overriding. All predefined globals become special. * eval.c (special, with_saved_vars_s): New global variables. (mark_special, special_p): New functions. (bindings_helper): Takes new argument, include_specials. Now processes the special colon syntax for denoting special variables, setting up their values, taking care to observe whether the binding is parallel or sequential. (op_let, op_for): Pass new argument to bindings_helper. (op_each): Pass new argument to bindings_helper with a value of it, and deal with the colon annotations that emerge in the bindings. (op_defvar, regvar): Mark symbol as special. (op_with_saved_vars): New static function. (expand_vars): Takes new argument, returns a cons. Detects special variables among the vars and produces the colon syntax. (expand_catch_clause): Bugfix: this was using expand_vars on a parameter list. Now properly uses expand_params. (expand_save_specials): New static function. (expand): For the operators that are binding constructs, handle the new form of expand_vars which returns information about special variables. If specials occur, then generate the with-saved-vars form around the expansion which will save and restore their values. The expansion of vars done by expand_vars, together with the run-time actions of bindings_helper, do the rest. Speaking of which, the new with-saved-vars operator form is now expanded here too. (eval_init): Protect new variables special and with_saved_vars_s. Initialize special with new hash table. Store new interned symbol in with_saved_vars_s. Register op_with_save_vars in op_table. * txr.1: Documented specials. --- eval.c | 205 +++++++++++++++++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 162 insertions(+), 43 deletions(-) (limited to 'eval.c') diff --git a/eval.c b/eval.c index 7abf8911..d293feab 100644 --- a/eval.c +++ b/eval.c @@ -71,7 +71,7 @@ struct c_var { val bind; }; -val top_vb, top_fb, top_mb; +val top_vb, top_fb, top_mb, special; val op_table; val eval_error_s; @@ -88,6 +88,7 @@ val delay_s, promise_s, op_s; val hash_lit_s, hash_construct_s; val vector_lit_s, vector_list_s; val macro_time_s; +val with_saved_vars_s; val whole_k, env_k; @@ -224,6 +225,16 @@ static val lookup_sym_lisp1(val env, val sym) } } +static void mark_special(val sym) +{ + sethash(special, sym, t); +} + +static val special_p(val sym) +{ + return gethash(special, sym); +} + static val bind_args(val env, val params, val args, val ctx_form) { val new_env = make_env(nil, nil, env); @@ -835,37 +846,55 @@ static val op_unquote_error(val form, val env) } -static val bindings_helper(val vars, val env, val sequential, val ctx_form) +static val bindings_helper(val vars, val env, val sequential, + val include_specials, val ctx_form) { val iter; list_collect_decl (new_bindings, ptail); val nenv = if3(sequential, make_env(nil, nil, env), env); + val spec_val[32], *spec_loc[32]; + int speci = 0; for (iter = vars; iter; iter = cdr(iter)) { val item = car(iter); - val var, val = nil; + val var, value = nil; if (consp(item)) { - if (!consp(cdr(item))) - eval_error(ctx_form, lit("~s: invalid syntax: ~s"), - car(ctx_form), item, nao); - var = first(item); - val = eval(second(item), nenv, ctx_form); + var = pop(&item); + value = eval(pop(&item), nenv, ctx_form); } else { var = item; } - if (symbolp(var)) { - if (!bindable(var)) + if (!bindable(var)) { + val special = car(item); + val *loc = lookup_var_l(nil, special); + if (var != colon_k) eval_error(ctx_form, lit("~s: ~s is not a bindable symbol"), car(ctx_form), var, nao); - } - - ptail = list_collect (ptail, cons(var, val)); + if (!loc) + eval_error(ctx_form, lit("~s: cannot rebind variable ~s: not found"), + car(ctx_form), special, nao); + if (sequential) { + *loc = value; + } else if (speci < 32) { + spec_val[speci] = value; + spec_loc[speci++] = loc; + } else { + eval_error(ctx_form, lit("~s: too many special variables rebound"), + car(ctx_form), nao); + } + if (include_specials) + ptail = list_collect (ptail, cons(colon_k, var)); + } else { + ptail = list_collect (ptail, cons(var, value)); - if (sequential) - env_replace_vbind(nenv, new_bindings); + if (sequential) + env_replace_vbind(nenv, new_bindings); + } } + while (speci-- > 0) + *spec_loc[speci] = spec_val[speci]; return new_bindings; } @@ -885,7 +914,7 @@ static val op_let(val form, val env) val args = rest(form); val vars = first(args); val body = rest(args); - val new_bindings = bindings_helper(vars, env, eq(let, let_star_s), form); + val new_bindings = bindings_helper(vars, env, eq(let, let_star_s), nil, form); return eval_progn(body, make_env(new_bindings, nil, env), form); } @@ -901,7 +930,7 @@ static val op_each(val form, val env) eq(each, append_each_star_s)); val collect = or2(eq(each, collect_each_s), eq(each, collect_each_star_s)); val append = or2(eq(each, append_each_s), eq(each, append_each_star_s)); - val new_bindings = bindings_helper(vars, env, star, form); + val new_bindings = bindings_helper(vars, env, star, t, form); val lists = mapcar(cdr_f, new_bindings); list_collect_decl (collection, ptail); @@ -915,9 +944,18 @@ static val op_each(val form, val env) { val binding = car(biter); val list = car(liter); + val sym = car(binding); if (!list) goto out; - rplacd(binding, car(list)); + if (sym == colon_k) { + val *loc = lookup_var_l(nil, cdr(binding)); + if (!loc) + eval_error(form, lit("~s: nonexistent special var ~a"), + car(form), sym); + *loc = car(list); + } else { + rplacd(binding, car(list)); + } rplaca(liter, cdr(list)); } @@ -1024,6 +1062,7 @@ static val op_defvar(val form, val env) val value = eval(second(args), env, form); sethash(top_vb, sym, cons(sym, value)); } + mark_special(sym); } return sym; @@ -1431,7 +1470,8 @@ static val op_for(val form, val env) val cond = third(form); val incs = fourth(form); val forms = rest(rest(rest(rest(form)))); - val new_bindings = bindings_helper(vars, env, eq(forsym, for_star_s), form); + val new_bindings = bindings_helper(vars, env, eq(forsym, for_star_s), + nil, form); val new_env = make_env(new_bindings, nil, env); uw_block_begin (nil, result); @@ -1652,6 +1692,39 @@ static val op_quasi_lit(val form, val env) return cat_str(subst_vars(rest(form), env), nil); } +static val op_with_saved_vars(val form, val env) +{ + val vars = (pop(&form), pop(&form)); + val prot_form = pop(&form); + val result = nil; + val var_save[32], *var_loc[32]; + int n; + + uw_simple_catch_begin; + + for (n = 0; n < 32 && vars; n++, vars = cdr(vars)) { + val sym = car(vars); + val *loc = lookup_var_l(nil, sym); + if (!loc) { + eval_error(form, lit("~s: cannot save value of " + "nonexistent var ~a"), car(form), sym, nao); + } + var_loc[n] = loc; + var_save[n] = *loc; + } + + result = eval(prot_form, env, prot_form); + + uw_unwind { + while (n-- > 0) + *var_loc[n] = var_save[n]; + } + + uw_catch_end; + + return result; +} + val expand_forms(val form) { if (atom(form)) { @@ -1791,26 +1864,42 @@ static val expand_qquote(val qquoted_form) abort(); } -static val expand_vars(val vars) +static val expand_vars(val vars, val specials) { + val sym; + if (atom(vars)) { return vars; - } else if (symbolp(car(vars))) { + } else if (special_p(sym = car(vars))) { + val rest_vars = rest(vars); + cons_bind (rest_vars_ex, new_specials, + rlcp(expand_vars(rest_vars, specials), rest_vars)); + val ret_specials = cons(sym, new_specials); + val var_ex = cons(colon_k, cons(nil, cons(sym, nil))); + return cons(rlcp(cons(var_ex, rest_vars_ex), vars), ret_specials); + } else if (symbolp(sym)) { val rest_vars = rest(vars); - val rest_vars_ex = expand_vars(rest_vars); + cons_bind (rest_vars_ex, new_specials, expand_vars(rest_vars, specials)); if (rest_vars == rest_vars_ex) - return vars; - return rlcp(cons(car(vars), rest_vars_ex), vars); + return cons(vars, new_specials); + return cons(rlcp(cons(sym, rest_vars_ex), vars), new_specials); } else { - cons_bind (var, init, car(vars)); + cons_bind (var, init, sym); val rest_vars = rest(vars); val init_ex = rlcp(expand_forms(init), init); - val rest_vars_ex = rlcp(expand_vars(rest_vars), rest_vars); + cons_bind (rest_vars_ex, new_specials, + rlcp(expand_vars(rest_vars, specials), rest_vars)); - if (init == init_ex && rest_vars == rest_vars_ex) - return vars; - - return rlcp(cons(cons(var, init_ex), rest_vars_ex), vars); + if (special_p(var)) { + val ret_specials = cons(var, new_specials); + val var_ex = cons(colon_k, cons(car(init_ex), cons(var, nil))); + return cons(rlcp(cons(var_ex, rest_vars_ex), vars), ret_specials); + } else { + if (init == init_ex && rest_vars == rest_vars_ex) + return cons(vars, new_specials); + return cons(rlcp(cons(cons(var, init_ex), rest_vars_ex), vars), + new_specials); + } } } @@ -1992,13 +2081,13 @@ static val expand_op(val sym, val body) static val expand_catch_clause(val form) { val sym = first(form); - val vars = second(form); + val params = second(form); val body = rest(rest(form)); - val vars_ex = expand_vars(vars); + val params_ex = expand_params(params); val body_ex = expand_forms(body); - if (body == body_ex && vars == vars_ex) + if (body == body_ex && params == params_ex) return form; - return rlcp(cons(sym, cons(vars_ex, body_ex)), form); + return rlcp(cons(sym, cons(params_ex, body_ex)), form); } static val expand_catch(val body) @@ -2017,6 +2106,13 @@ static val expand_catch(val body) return rlcp(expanded, body); } +static val expand_save_specials(val form, val specials) +{ + if (!specials) + return form; + return rlcp(cons(with_saved_vars_s, cons(specials, cons(form, nil))), form); +} + val expand(val form) { val macro = nil; @@ -2035,10 +2131,13 @@ tail: val body = rest(rest(form)); val vars = second(form); val body_ex = expand_forms(body); - val vars_ex = expand_vars(vars); - if (body == body_ex && vars == vars_ex) + cons_bind (vars_ex, specials, expand_vars(vars, nil)); + if (body == body_ex && vars == vars_ex && !specials) { return form; - return rlcp(cons(sym, cons(vars_ex, body_ex)), form); + } else { + val basic_form = rlcp(cons(sym, cons(vars_ex, body_ex)), form); + return expand_save_specials(basic_form, specials); + } } else if (sym == block_s || sym == return_from_s) { val name = second(form); val body = rest(rest(form)); @@ -2134,17 +2233,21 @@ tail: val cond = third(form); val incs = fourth(form); val forms = rest(rest(rest(rest(form)))); - val vars_ex = expand_vars(vars); + cons_bind (vars_ex, specials, expand_vars(vars, nil)); val cond_ex = expand_forms(cond); val incs_ex = expand_forms(incs); val forms_ex = expand_forms(forms); if (vars == vars_ex && cond == cond_ex && - incs == incs_ex && forms == forms_ex) + incs == incs_ex && forms == forms_ex && !specials) { return form; - return rlcp(cons(sym, - cons(vars_ex, - cons(cond_ex, cons(incs_ex, forms_ex)))), form); + } else { + val basic_form = rlcp(cons(sym, + cons(vars_ex, + cons(cond_ex, + cons(incs_ex, forms_ex)))), form); + return expand_save_specials(basic_form, specials); + } } else if (sym == dohash_s) { val spec = second(form); val keysym = first(spec); @@ -2186,6 +2289,17 @@ tail: val args_ex = expand_forms(args); val result = eval_progn(args_ex, make_env(nil, nil, nil), args); return cons(quote_s, cons(result, nil)); + } else if (sym == with_saved_vars_s) { + /* We should never have to expand a machine-generated with-saved-vars + * produced by the expander itself. This is for the sake of someone + * testing with-saved-vars in isolation. + */ + val vars = first(form); + val expr = second(form); + val expr_ex = expand(expr); + if (expr == expr_ex) + return form; + return cons(vars, cons(expr_ex, nil)); } else if ((macro = gethash(top_mb, sym))) { val mac_expand = expand_macro(form, macro, make_env(nil, nil, nil)); if (mac_expand == form) @@ -2624,6 +2738,7 @@ static void reg_var(val sym, val *loc) cv->loc = loc; cv->bind = cons(sym, *loc); sethash(top_vb, sym, cobj((mem_t *) cv, cptr_s, &c_var_ops)); + mark_special(sym); } static val if_fun(val cond, val then, val alt) @@ -2656,10 +2771,12 @@ static val and_fun(val vals) void eval_init(void) { - protect(&top_vb, &top_fb, &top_mb, &op_table, &last_form_evaled, (val *) 0); + protect(&top_vb, &top_fb, &top_mb, &special, + &op_table, &last_form_evaled, (val *) 0); top_fb = make_hash(t, nil, nil); top_vb = make_hash(t, nil, nil); top_mb = make_hash(t, nil, nil); + special = make_hash(t, nil, nil); op_table = make_hash(nil, nil, nil); dwim_s = intern(lit("dwim"), user_package); @@ -2712,6 +2829,7 @@ void eval_init(void) vector_lit_s = intern(lit("vector-lit"), system_package); vector_list_s = intern(lit("vector-list"), user_package); macro_time_s = intern(lit("macro-time"), user_package); + with_saved_vars_s = intern(lit("with-saved-vars"), system_package); whole_k = intern(lit("whole"), keyword_package); sethash(op_table, quote_s, cptr((mem_t *) op_quote)); @@ -2757,6 +2875,7 @@ void eval_init(void) sethash(op_table, dwim_s, cptr((mem_t *) op_dwim)); sethash(op_table, quasi_s, cptr((mem_t *) op_quasi_lit)); sethash(op_table, catch_s, cptr((mem_t *) op_catch)); + sethash(op_table, with_saved_vars_s, cptr((mem_t *) op_with_saved_vars)); reg_fun(cons_s, func_n2(cons)); reg_fun(intern(lit("make-lazy-cons"), user_package), func_n1(make_lazy_cons)); -- cgit v1.2.3