Changing how binding of special variables works.

The old way: process, at expansion time, bindings in lambda
lists and all binding constructs to find special variables
(symbols marked special). Replace these bindings with
an annotation. Then when the interpreter performs binding,
the binding helper functions process these annotations.
Also, if specials occur, wrap the construct in
sys:with-save-specials to set up the necessary dynamic
environment frame.

The new way: process, at expansion time, bindings in
lambda lists and binding constructs (which have been reduced
to just let and let*). If special variables occur, then
wrap the body in in sys:with-dyn-rebinds which re-binds
specific symbols in the dynamic namespace, copying their
value from their lexical binding.  The lexical bindings are
then replaced with the value sys:unbound, which indicates that
the value should be resolved in the dynamic environment.

* eval.c (with_saved_vars_s): Symbol variable removed.
(with_dyn_rebinds_s): New symbol variable.
(lookup_var, lookup_sym_lisp1): If a lexical binding contains
the value sys:unbound, then continue the search through the
dynamic environment; ignore the remaining lexical
environments.
(expand_params_rec): Bugfix: neglected collect of
special variable in fallback case.
(expand_params): Takes body environment, and returns two
values as a cons cell. The additional return value is a body
that is either the original body, or else is wrapped with
sys:with-dyn-rebinds. Removed is the special variable
hack inserted into the syntax.
(expand_macrolet, expand_tree_cases): Adjust to new
expand_params interface.
(op_with_saved_vars): Static function removed.
(op_with_dyn_rebinds): New static function.
(expand_vars): Return list of special variables via pointer
argument, rather than just a Boolean which indicates that
specials are present. Transformation to special representation
is removed.
(expand_catch_clause): Adjust to new expand_params interface.
(expand_save_specials): Static function removed.
(do_expand): Adjust let/let* expansion to new expand_vars
interface. Generate the sys:with-dyn-rebinds wrapping around
the body. Adjust the defun, lambda and mac-param-bind
expanders to the new expand_params interface.
Recognize sys:with-dyn-rebinds and don't expand it;
all places which generate this form have to expand the
internals themselves.
(eval_init): Remove initialization of with_saved_var_s,
and its registration as an operator.
Initialize with_dyn_rebinds_s with interned symbol,
and register as operator.

1 files changed, 72 insertions, 60 deletions

diff --git a/eval.c b/eval.c
index d14a6acb..676666d8 100644
--- a/eval.c
+++ b/eval.c
@@ -96,7 +96,7 @@ val op_s, ap_s, identity_s, apf_s, ipf_s;
 val ret_s, aret_s;
 val hash_lit_s, hash_construct_s, struct_lit_s, qref_s;
 val vector_lit_s, vec_list_s;
-val macro_time_s, with_saved_vars_s, macrolet_s;
+val macro_time_s, with_dyn_rebinds_s, macrolet_s;
 val defsymacro_s, symacrolet_s, prof_s, switch_s;
 val fbind_s, lbind_s, flet_s, labels_s;
 val opip_s, oand_s, chain_s, chand_s;
@@ -375,8 +375,11 @@ val lookup_var(val env, val sym)
 
     for (; env; env = env->e.up_env) {
       val binding = assoc(sym, env->e.vbindings);
-      if (binding)
+      if (binding) {
+        if (cdr(binding) == unbound_s)
+          break;
         return binding;
+      }
     }
   }
 
@@ -399,8 +402,11 @@ static val lookup_sym_lisp1(val env, val sym)
     for (; env; env = env->e.up_env) {
       val binding = or2(assoc(sym, env->e.vbindings),
                         assoc(sym, env->e.fbindings));
-      if (binding)
+      if (binding) {
+        if (cdr(binding) == unbound_s)
+          break;
         return binding;
+      }
     }
   }
 
@@ -831,19 +837,24 @@ static val expand_params_rec(val params, val menv, val *pspecials)
     return rlcp(cons(car_ex, params_ex), params);
   } else {
     val params_ex = expand_params_rec(cdr(params), menv, pspecials);
+    if (special_var_p(car(params)))
+      push(car(params), 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)
+static val expand_params(val params, val body, val menv)
 {
   val specials = nil;
+  int have_rebinds = consp(body) && consp(car(body)) && caar(body) == with_dyn_rebinds_s;
   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 body_out = if3(!have_rebinds && specials,
+                     rlcp(cons(cons(with_dyn_rebinds_s, cons(specials, body)),
+                               nil), nil),
+                     body);
+  return cons(params_ex, body_out);
 }
 
 static val get_param_syms(val params);
@@ -1840,9 +1851,9 @@ static val expand_macrolet(val form, val menv)
     val name = pop(&macro);
     val params = pop(&macro);
     val new_menv = make_var_shadowing_env(menv, get_param_syms(params));
-    val params_ex = expand_params(params, menv);
     val macro_ex = expand_forms(macro, new_menv);
-    val block = rlcp_tree(cons(block_s, cons(name, macro_ex)), macro_ex);
+    cons_bind (params_ex, macro_out, expand_params(params, macro_ex, menv));
+    val block = rlcp_tree(cons(block_s, cons(name, macro_out)), macro_ex);
 
     builtin_reject_test(op, name, form);
 
@@ -1922,8 +1933,9 @@ static val expand_tree_cases(val cases, val menv)
       val dstr_args = car(onecase);
       val forms = cdr(onecase);
       val new_menv = make_var_shadowing_env(menv, get_param_syms(dstr_args));
-      val dstr_args_ex = expand_params(dstr_args, menv);
-      val forms_ex = expand_forms(forms, new_menv);
+      val forms_ex0 = expand_forms(forms, new_menv);
+      cons_bind (dstr_args_ex, forms_ex,
+                 expand_params(dstr_args, forms_ex0, menv));
       val rest_ex = expand_tree_cases(cdr(cases), menv);
 
       if (dstr_args_ex == dstr_args && forms_ex == forms &&
@@ -2424,13 +2436,25 @@ static val op_quasi_lit(val form, val env)
   return cat_str(subst_vars(rest(form), env, nil), nil);
 }
 
-static val op_with_saved_vars(val form, val env)
+static val op_with_dyn_rebinds(val form, val env)
 {
-  val prot_form = second(form);
-  val saved_de = set_dyn_env(make_env(nil, nil, dyn_env));
-  val result = eval(prot_form, env, prot_form);
-  set_dyn_env(saved_de);
-  return result;
+  val rebind_vars = cadr(form);
+  val body = cddr(form);
+  list_collect_decl (dbinds, ptail);
+
+  for (; rebind_vars; rebind_vars = cdr(rebind_vars)) {
+    val sym = car(rebind_vars);
+    val binding = lookup_var(env, car(rebind_vars));
+    ptail = list_collect(ptail, cons(sym, cdr(binding)));
+    rplacd(binding, unbound_s);
+  }
+
+  {
+    val saved_de = set_dyn_env(make_env(dbinds, nil, dyn_env));
+    val result = eval_progn(body, env, form);
+    set_dyn_env(saved_de);
+    return result;
+  }
 }
 
 static val op_prof(val form, val env)
@@ -2980,7 +3004,7 @@ static val me_equot(val form, val menv)
 }
 
 static val expand_vars(val vars, val menv, val form,
-                       val *spec_p, int seq_p)
+                       val *pspecials, int seq_p)
 {
   val sym;
 
@@ -2990,15 +3014,11 @@ static val expand_vars(val vars, val menv, val form,
     eval_error(form, lit("~a is an invalid variable binding syntax"),
                vars, nao);
     return vars;
-  } else if (special_var_p(sym = car(vars))) {
-    val rest_vars = rest(vars);
-    val rest_vars_ex = rlcp(expand_vars(rest_vars, menv, form, spec_p, seq_p),
-                            rest_vars);
-    val var_ex = cons(special_s, cons(nil, cons(sym, nil)));
-    return rlcp(cons(var_ex, rest_vars_ex), vars);
-  } else if (symbolp(sym)) {
+  } else if (symbolp(sym = car(vars))) {
     val rest_vars = rest(vars);
-    val rest_vars_ex = expand_vars(rest_vars, menv, form, spec_p, seq_p);
+    val rest_vars_ex = expand_vars(rest_vars, menv, form, pspecials, seq_p);
+    if (special_var_p(sym))
+      push(sym, pspecials);
     if (rest_vars == rest_vars_ex)
       return vars;
     return rlcp(cons(sym, rest_vars_ex), vars);
@@ -3012,18 +3032,14 @@ static val expand_vars(val vars, val menv, val form,
        do not see a previous symbol macro; they see the var. */
     val menv_new = seq_p ? make_var_shadowing_env(menv, cons(var, nil)) : menv;
     val rest_vars_ex = rlcp(expand_vars(rest_vars, menv_new, form,
-                                        spec_p, seq_p),
+                                        pspecials, seq_p),
                             rest_vars);
 
-    if (special_var_p(var)) {
-      val var_ex = cons(special_s, cons(car(init_ex), cons(var, nil)));
-      *spec_p = t;
-      return rlcp(cons(var_ex, rest_vars_ex), vars);
-    } else {
-      if (init == init_ex && rest_vars == rest_vars_ex)
-        return vars;
-      return rlcp(cons(cons(var, init_ex), rest_vars_ex), vars);
-    }
+    if (special_var_p(var))
+      push(var, pspecials);
+    if (init == init_ex && rest_vars == rest_vars_ex)
+      return vars;
+    return rlcp(cons(cons(var, init_ex), rest_vars_ex), vars);
   }
 }
 
@@ -3606,8 +3622,8 @@ static val expand_catch_clause(val form, val menv)
   val params = second(form);
   val body = rest(rest(form));
   val new_menv = make_var_shadowing_env(menv, get_param_syms(params));
-  val params_ex = expand_params(params, menv);
-  val body_ex = expand_forms(body, new_menv);
+  val body_ex0 = expand_forms(body, new_menv);
+  cons_bind (params_ex, body_ex, expand_params(params, body_ex0, menv));
   if (body == body_ex && params == params_ex)
     return form;
   return rlcp(cons(sym, cons(params_ex, body_ex)), form);
@@ -3630,13 +3646,6 @@ static val expand_catch(val body, val menv)
   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(form, nil)), form);
-}
-
 static val expand_list_of_form_lists(val lofl, val menv, val ss_hash)
 {
   list_collect_decl (out, ptail);
@@ -3703,13 +3712,17 @@ static val do_expand(val form, val menv)
       int seq_p = sym == let_star_s;
       val new_menv = make_var_shadowing_env(menv, vars);
       val body_ex = expand_progn(body, new_menv);
-      val specials_p = nil;
-      val vars_ex = expand_vars(vars, menv, form, &specials_p, seq_p);
-      if (body == body_ex && vars == vars_ex && !specials_p) {
+      val specials = nil;
+      val vars_ex = expand_vars(vars, menv, form, &specials, seq_p);
+      int have_rebinds = consp(car(body)) && caar(body) == with_dyn_rebinds_s;
+      if (body == body_ex && vars == vars_ex && (!specials || have_rebinds)) {
         return form;
+      } else if (!specials || have_rebinds) {
+        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_p);
+        val body_rebinds = rlcp(cons(with_dyn_rebinds_s,
+                                     cons(specials, body_ex)), form);
+        return rlcp(cons(sym, cons(vars_ex, cons(body_rebinds, nil))), form);
       }
     } else if (sym == each_op_s) {
       val args = rest(form);
@@ -3783,8 +3796,8 @@ static val do_expand(val form, val menv)
         val params = second(form);
         val body = rest(rest(form));
         val new_menv = make_var_shadowing_env(menv, get_param_syms(params));
-        val params_ex = expand_params(params, menv);
-        val body_ex = expand_progn(body, new_menv);
+        val body_ex0 = expand_progn(body, new_menv);
+        cons_bind (params_ex, body_ex, expand_params(params, body_ex0, menv));
 
         if (body == body_ex && params == params_ex)
           return form;
@@ -3804,12 +3817,11 @@ static val do_expand(val form, val menv)
         val new_menv = if3(sym == defun_s,
                            make_fun_shadowing_env(inter_env, cons(name, nil)),
                            inter_env);
-        val params_ex = expand_params(params, menv);
         val body = rest(rest(rest(form)));
-        val body_ex = expand_progn(body, new_menv);
+        val body_ex0 = expand_progn(body, new_menv);
+        cons_bind (params_ex, body_ex, expand_params(params, body_ex0, menv));
         val form_ex = form;
 
-
         if (body != body_ex || params != params_ex)
           form_ex = rlcp(cons(sym, cons(name, cons(params_ex, body_ex))), form);
 
@@ -3829,9 +3841,9 @@ static val do_expand(val form, val menv)
       val body = args;
       val new_menv = make_var_shadowing_env(menv, get_param_syms(params));
       val ctx_expr_ex = expand(expr, menv);
-      val params_ex = expand_params(params, menv);
+      val body_ex0 = expand_progn(body, new_menv);
+      cons_bind (params_ex, body_ex, expand_params(params, body_ex0, menv));
       val expr_ex = expand(expr, new_menv);
-      val body_ex = expand_progn(body, new_menv);
 
       if (sym == mac_param_bind_s) {
         if (ctx_expr_ex == ctx_expr && params_ex == params &&
@@ -3845,7 +3857,7 @@ static val do_expand(val form, val menv)
       if (params_ex == params && expr_ex == expr && body_ex == body)
         return form;
       return rlcp(cons(sym, cons(params_ex, cons(expr_ex, body_ex))), form);
-    } else if (sym == quote_s || sym == fun_s) {
+    } else if (sym == quote_s || sym == fun_s || sym == with_dyn_rebinds_s) {
       return form;
     } else if (sym == for_op_s) {
       val vars = second(form);
@@ -5052,7 +5064,7 @@ void eval_init(void)
   macro_time_s = intern(lit("macro-time"), user_package);
   macrolet_s = intern(lit("macrolet"), user_package);
   symacrolet_s = intern(lit("symacrolet"), user_package);
-  with_saved_vars_s = intern(lit("with-saved-vars"), system_package);
+  with_dyn_rebinds_s = intern(lit("with-dyn-rebinds"), system_package);
   whole_k = intern(lit("whole"), keyword_package);
   form_k = intern(lit("form"), keyword_package);
   special_s = intern(lit("special"), system_package);
@@ -5117,7 +5129,7 @@ void eval_init(void)
   reg_op(quasi_s, op_quasi_lit);
   reg_op(catch_s, op_catch);
   reg_op(handler_bind_s, op_handler_bind);
-  reg_op(with_saved_vars_s, op_with_saved_vars);
+  reg_op(with_dyn_rebinds_s, op_with_dyn_rebinds);
   reg_op(prof_s, op_prof);
   reg_op(switch_s, op_switch);