From a313d780ec41e52ad9b20842e56c553af6eb1a47 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Sun, 23 Feb 2014 17:57:20 -0800 Subject: Get special variable overriding working in function and macro parameter lists. There is a bugfix here too (see eval_init below). * eval.c (special_s): New global variable. This symbol is used as a marker in parameter lists denoting expander-generating syntax that gives information about specials. (lookup_var, looup_var_l): Bugfix: walk the dynamic chain properly. Fallback from the lexical chain to the dynamic. (env_vbind_special): New static function. (bind_args, bind_macro_params): Detect special list in params. Use env_vbind_special to bind variables either in the dynamic environment or the lexical one. (expand_opt_params, expand_params): Renamed to expand_opt_params_rec and expand_params_rec, respectively. Now take extra argument for accumulating list of special variables found in the param list. (expand_params): New static function. (set_dyn_env): New static function. (interp_fun, expand_macro): Set up and tear down new dynamic environment around parameter list evaluation and body evaluation. This will take any new dynamic bindings. (bindings_helper, op_each): The special_s symbol is now used instead of colon_k for marking specials. (op_defun): Recognize the specials added to the parameter list so as not to t report that as not a bindable symbol. (op_catch): Set up an tear down new dynamic environment around the evaluation of the catch clause param binding and body. (expand_vars): use colon_s symbol instead of colon_k for marking special var. (eval_init): Bugfix: gc-protect recently added dyn_env variable. Intern special symbol into special_s variable. --- eval.c | 170 ++++++++++++++++++++++++++++++++++++++++++++++------------------- 1 file changed, 122 insertions(+), 48 deletions(-) (limited to 'eval.c') diff --git a/eval.c b/eval.c index 8c411f2e..71d1d4ad 100644 --- a/eval.c +++ b/eval.c @@ -90,7 +90,7 @@ val hash_lit_s, hash_construct_s; val vector_lit_s, vector_list_s; val macro_time_s, with_saved_vars_s, macrolet_s; -val whole_k, env_k; +val special_s, whole_k, env_k; val last_form_evaled; @@ -142,8 +142,9 @@ noreturn static val eval_error(val form, val fmt, ...) val lookup_var(val env, val sym) { if (nilp(env)) { - if (dyn_env) { - val binding = assoc(sym, dyn_env->e.vbindings); +dyn: + for (env = dyn_env; env; env = env->e.up_env) { + val binding = assoc(sym, env->e.vbindings); if (binding) return binding; } @@ -160,20 +161,22 @@ val lookup_var(val env, val sym) } else { type_check(env, ENV); - { + for (; env; env = env->e.up_env) { val binding = assoc(sym, env->e.vbindings); if (binding) return binding; - return lookup_var(env->e.up_env, sym); } + + goto dyn; } } val *lookup_var_l(val env, val sym) { if (nilp(env)) { - if (dyn_env) { - val binding = assoc(sym, dyn_env->e.vbindings); +dyn: + for (env = dyn_env; env; env = env->e.up_env) { + val binding = assoc(sym, env->e.vbindings); if (binding) return cdr_l(binding); } @@ -191,12 +194,13 @@ val *lookup_var_l(val env, val sym) } else { type_check(env, ENV); - { + for (; env; env = env->e.up_env) { val binding = assoc(sym, env->e.vbindings); if (binding) return cdr_l(binding); - return lookup_var_l(env->e.up_env, sym); } + + goto dyn; } } @@ -268,12 +272,25 @@ static val special_p(val sym) return gethash(special, sym); } +static val env_vbind_special(val env, val sym, val obj, + val special_list, val ctx_form) +{ + if (special_list && memq(sym, special_list)) { + if (dyn_env) + return env_vbind(dyn_env, sym, obj); + internal_error("cannot rebind special var: there is no dynamic env"); + } else { + return env_vbind(env, sym, obj); + } +} + static val bind_args(val env, val params, val args, val ctx_form) { val new_env = make_env(nil, nil, env); val optargs = nil; + val special_list = nil; - for (; args && consp(params); args = cdr(args), params = cdr(params)) { + for (; args && consp(params); params = cdr(params)) { val param = car(params); val initform = nil; val presentsym = nil; @@ -282,17 +299,22 @@ static val bind_args(val env, val params, val args, val ctx_form) if (optargs) goto twocol; optargs = t; - params = cdr(params); - if (!consp(params)) - break; - param = car(params); + continue; } - if (optargs && consp(param)) { + if (consp(param)) { val sym = pop(¶m); - initform = pop(¶m); - presentsym = pop(¶m); - param = sym; + if (optargs) { + initform = pop(¶m); + presentsym = pop(¶m); + param = sym; + } else if (sym == special_s) { + special_list = param; + continue; + } else { + eval_error(ctx_form, lit("~s: bad object ~s in param list"), + car(ctx_form), sym, nao); + } } if (!bindable(param)) @@ -317,16 +339,18 @@ static val bind_args(val env, val params, val args, val ctx_form) initval = arg; present = t; } - env_vbind(new_env, param, initval); + env_vbind_special(new_env, param, initval, special_list, ctx_form); if (presentsym) - env_vbind(new_env, presentsym, present); + env_vbind_special(new_env, presentsym, present, special_list, ctx_form); } else { env_vbind(new_env, param, car(args)); } + + args = cdr(args); } if (bindable(params)) { - env_vbind(new_env, params, args); + env_vbind_special(new_env, params, args, special_list, ctx_form); } else if (consp(params)) { if (car(params) == colon_k) { if (optargs) @@ -350,20 +374,20 @@ static val bind_args(val env, val params, val args, val ctx_form) car(ctx_form), sym, nao); new_env = make_env(nil, nil, new_env); - env_vbind(new_env, sym, initval); + env_vbind_special(new_env, sym, initval, special_list, ctx_form); if (presentsym) { if (!bindable(presentsym)) eval_error(ctx_form, lit("~s: ~s is not a bindable symbol"), car(ctx_form), presentsym, nao); - env_vbind(new_env, presentsym, nil); + env_vbind_special(new_env, presentsym, nil, special_list, ctx_form); } } else { - env_vbind(new_env, param, nil); + env_vbind_special(new_env, param, nil, special_list, ctx_form); } params = cdr(params); } if (bindable(params)) - env_vbind(new_env, params, nil); + env_vbind_special(new_env, params, nil, special_list, ctx_form); } else if (params) { eval_error(ctx_form, lit("~s: ~s is not a bindable symbol"), car(ctx_form), params, nao); @@ -378,51 +402,70 @@ twocol: car(ctx_form), nao); } -static val expand_opt_params(val params, val menv) +static val expand_opt_params_rec(val params, val menv, val *pspecials) { if (atom(params)) { + if (special_p(params)) + push(params, pspecials); return params; } else { val form = car(params); if (atom(form) || !consp(cdr(form))) { /* sym, or no init form */ - val params_ex = expand_opt_params(cdr(params), menv); + val params_ex = expand_opt_params_rec(cdr(params), menv, pspecials); + if (special_p(form)) + push(form, pspecials); if (params_ex == cdr(params)) return params; return rlcp(cons(form, params_ex), cdr(params)); } else { /* has initform */ + val sym = car(form); val initform = car(cdr(form)); val initform_ex = rlcp(expand(initform, menv), initform); val form_ex = rlcp(cons(car(form), cons(initform_ex, cdr(cdr(form)))), form); - return rlcp(cons(form_ex, expand_opt_params(rest(params), menv)), + if (special_p(sym)) + push(sym, pspecials); + return rlcp(cons(form_ex, expand_opt_params_rec(rest(params), + menv, pspecials)), cdr(params)); } } } -static val expand_params(val params, val menv) +static val expand_params_rec(val params, val menv, val *pspecials) { if (atom(params)) { + if (special_p(params)) + push(params, pspecials); return params; } else if (car(params) == colon_k) { - val params_ex = expand_opt_params(cdr(params), menv); + val params_ex = expand_opt_params_rec(cdr(params), menv, pspecials); if (params_ex == cdr(params)) return params; return rlcp(cons(colon_k, params_ex), cdr(params)); } else if (consp(car(params))) { - val car_ex = expand_params(car(params), menv); - val params_ex = expand_params(cdr(params), menv); + val car_ex = expand_params_rec(car(params), menv, pspecials); + val params_ex = expand_params_rec(cdr(params), menv, pspecials); if (car_ex == car(params) && params_ex == cdr(params)) return params; return rlcp(cons(car_ex, params_ex), params); } else { - val params_ex = expand_params(cdr(params), menv); + val params_ex = expand_params_rec(cdr(params), menv, pspecials); if (params_ex == cdr(params)) return params; return rlcp(cons(car(params), params_ex), cdr(params)); } } +static val expand_params(val params, val menv) +{ + val specials = nil; + val params_ex = expand_params_rec(params, menv, &specials); + return if3(specials, + rlcp(cons(cons(special_s, specials), params_ex), params_ex), + params_ex); +} + val apply(val fun, val arglist, val ctx_form) { val arg[32], *p = arg; @@ -582,6 +625,18 @@ static val bind_macro_params(val env, val menv, val params, val form, val err_sym = nil; val whole = form; val optargs = nil; + val specials = nil; + + if (consp(params)) { + val head = car(params); + if (consp(head)) { + val sym = car(head); + if (sym == special_s) { + specials = cdr(head); + params = cdr(params); + } + } + } while (consp(params)) { val param = car(params); @@ -597,7 +652,8 @@ static val bind_macro_params(val env, val menv, val params, val form, err_sym = nparam; goto nbind; } - env_vbind(new_env, nparam, if3(param == whole_k, whole, menv)); + env_vbind_special(new_env, nparam, if3(param == whole_k, whole, menv), + specials, ctx_form); params = cdr(next); continue; } @@ -617,7 +673,7 @@ static val bind_macro_params(val env, val menv, val params, val form, } if (bindable(param)) { - env_vbind(new_env, param, car(form)); + env_vbind_special(new_env, param, car(form), specials, ctx_form); } else if (consp(param)) { if (optargs) { val nparam = pop(¶m); @@ -635,7 +691,7 @@ static val bind_macro_params(val env, val menv, val params, val form, nparam, car(form), t, ctx_form); if (presentsym) - env_vbind(new_env, presentsym, t); + env_vbind_special(new_env, presentsym, t, specials, ctx_form); } else { new_env = bind_macro_params(new_env, menv, param, car(form), @@ -669,7 +725,7 @@ static val bind_macro_params(val env, val menv, val params, val form, noarg: if (bindable(param)) { - env_vbind(new_env, param, nil); + env_vbind_special(new_env, param, nil, specials, ctx_form); } else if (consp(param)) { val nparam = pop(¶m); val initform = pop(¶m); @@ -690,7 +746,7 @@ noarg: } if (presentsym) - env_vbind(new_env, presentsym, nil); + env_vbind_special(new_env, presentsym, nil, specials, ctx_form); } else { err_sym = param; goto nbind; @@ -704,7 +760,7 @@ noarg: err_sym = params; goto nbind; } - env_vbind(new_env, params, form); + env_vbind_special(new_env, params, form, specials, ctx_form); return new_env; } @@ -743,13 +799,23 @@ static val do_eval_args(val form, val env, val ctx_form, return values; } +static val set_dyn_env(val de) +{ + val old = dyn_env; + dyn_env = de; + return old; +} + val interp_fun(val env, val fun, val args) { val def = cdr(fun); val params = car(def); val body = cdr(def); + val saved_de = set_dyn_env(make_env(nil, nil, dyn_env)); val fun_env = bind_args(env, params, args, fun); - return eval_progn(body, fun_env, body); + val ret = eval_progn(body, fun_env, body); + set_dyn_env(saved_de); + return ret; } val eval_intrinsic(val form, val env) @@ -902,7 +968,7 @@ static val bindings_helper(val vars, val env, val sequential, if (!bindable(var)) { val special = car(item); val *loc = lookup_var_l(nil, special); - if (var != colon_k) + if (var != special_s) eval_error(ctx_form, lit("~s: ~s is not a bindable symbol"), car(ctx_form), var, nao); if (!loc) @@ -918,7 +984,7 @@ static val bindings_helper(val vars, val env, val sequential, car(ctx_form), nao); } if (include_specials) - ptail = list_collect (ptail, cons(colon_k, var)); + ptail = list_collect (ptail, cons(special_s, var)); } else { ptail = list_collect (ptail, cons(var, value)); @@ -980,7 +1046,7 @@ static val op_each(val form, val env) val sym = car(binding); if (!list) goto out; - if (sym == colon_k) { + if (sym == special_s) { val *loc = lookup_var_l(nil, cdr(binding)); if (!loc) eval_error(form, lit("~s: nonexistent special var ~a"), @@ -1126,8 +1192,11 @@ static val op_defun(val form, val env) } if (colon && consp(param)) continue; - if (!bindable(param)) + if (!bindable(param)) { + if (consp(param) && car(param) == special_s) + continue; /* special vars list */ eval_error(form, lit("defun: parameter ~s is not a bindable symbol"), param, nao); + } } if (iter && !bindable(iter)) @@ -1162,10 +1231,12 @@ static val expand_macro(val form, val expander, val menv) val env = car(cdr(expander)); val params = car(cdr(cdr(expander))); val body = cdr(cdr(cdr(expander))); + val saved_de = set_dyn_env(make_env(nil, nil, dyn_env)); val exp_env = bind_macro_params(env, menv, params, args, nil, form); debug_frame(name, args, nil, env, nil, nil, nil); debug_return(eval_progn(body, exp_env, body)); debug_end; + set_dyn_env(saved_de); /* not reached but shuts up compiler */ debug_leave; } @@ -1203,7 +1274,7 @@ static val op_tree_case(val form, val env) val onecase = car(cases); cons_bind (params, forms, onecase); val new_env = bind_macro_params(env, nil, params, expr_val, - colon_k, onecase); + colon_k, onecase); if (new_env) { val ret = eval_progn(forms, new_env, forms); if (ret != colon_k) @@ -1651,10 +1722,12 @@ static val op_catch(val form, val env) if (uw_exception_subtype_p(exsym, type)) { val params = second(clause); + val saved_de = set_dyn_env(make_env(nil, nil, dyn_env)); val clause_env = bind_args(env, params, if3(listp(exvals), exvals, cons(exvals, nil)), clause); result = eval_progn(rest(rest(clause)), clause_env, clause); + set_dyn_env(saved_de); break; } } @@ -1935,7 +2008,7 @@ static val expand_vars(val vars, val specials, val menv) cons_bind (rest_vars_ex, new_specials, rlcp(expand_vars(rest_vars, specials, menv), rest_vars)); val ret_specials = cons(sym, new_specials); - val var_ex = cons(colon_k, cons(nil, cons(sym, nil))); + val var_ex = cons(special_s, 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); @@ -1953,7 +2026,7 @@ static val expand_vars(val vars, val specials, val menv) if (special_p(var)) { val ret_specials = cons(var, new_specials); - val var_ex = cons(colon_k, cons(car(init_ex), cons(var, nil))); + val var_ex = cons(special_s, 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) @@ -2855,7 +2928,7 @@ static val pprinl(val obj, val stream) void eval_init(void) { - protect(&top_vb, &top_fb, &top_mb, &special, + protect(&top_vb, &top_fb, &top_mb, &special, &dyn_env, &op_table, &last_form_evaled, (val *) 0); top_fb = make_hash(t, nil, nil); top_vb = make_hash(t, nil, nil); @@ -2916,6 +2989,7 @@ void eval_init(void) macrolet_s = intern(lit("macrolet"), user_package); with_saved_vars_s = intern(lit("with-saved-vars"), system_package); whole_k = intern(lit("whole"), keyword_package); + special_s = intern(lit("special"), system_package); sethash(op_table, quote_s, cptr((mem_t *) op_quote)); sethash(op_table, qquote_s, cptr((mem_t *) op_qquote_error)); -- cgit v1.2.3