Different approach for specials in let/let*.

This addresses a problem with the new scheme for handling
specials. If we let specials be bound in the lexical
environment and then do the swizzle into the dynamic
environment using sys:with-dyn-rebinds, that only works
correctly for parallel bindings (and thus also for lambda and
macro parameters).  For sequential bindings, it exposes the
possibility that a closure is created during the sequential
binding which captures a would-be special variable while it is
still in the lexical stage. That closure can be thrown out of
there, so the sys:with-dyn-rebinds is never reached which
swizzles the variable.

The new scheme is very simple. When expanding a let, we
tranform (s init) to (s (sys:dvbind s init)) if s is a special
variable. This new sys:dvbind operator binds s to the value of
the init expression in a newly created dynamic environment,
and returns the #:unbound symbol, which is received by the
lexical s. Problem solved. The only thing remains is that the
let special operator must save and restore the dynamic
environment.

There is no need for sys:with-dyn-rebinds around the body
of a let, but we keep that mechanism and approach for handling
specials in argument lists.

* eval.c (dvbind_s): New symbol variale.
(bindings_helper): Lose the env_out argument; return the new
environment. No caller uses the returned bindings any more.
(op_let): Call bindings_helper in initializing expression of
new_env. Save the dyn_env, and restore it after evaluating
the body.
(op_dvbind): New static function.
(expand_vars): Lose the pspecials argument. Perform
the insertion of sys:dvbind.
(do_expand): Simplify the let expander: expand_vars no longer
outputs a list of specials and there is no need to insert
with_dyn_rebinds_s. Add a case for sys:dvbind: assume it
requires no expansion.
(eval_init): Intern sys:dvbind, and bind it as an operator
to the new op_dvbind function.

1 files changed, 49 insertions, 36 deletions

diff --git a/eval.c b/eval.c
index 251a5743..8963bb2f 100644
--- a/eval.c
+++ b/eval.c
@@ -73,7 +73,7 @@ val dyn_env;
 val eval_initing;
 
 val eval_error_s;
-val dwim_s, progn_s, prog1_s, let_s, let_star_s, lambda_s, call_s;
+val dwim_s, progn_s, prog1_s, let_s, let_star_s, lambda_s, call_s, dvbind_s;
 val handler_bind_s, cond_s, if_s, iflet_s, when_s;
 val defvar_s, defvarl_s, defparm_s, defparml_s, defun_s, defmacro_s, macro_s;
 val tree_case_s, tree_bind_s, mac_param_bind_s;
@@ -1324,8 +1324,7 @@ static void copy_bh_env_handler(mem_t *ptr, int parent)
 }
 
 static val bindings_helper(val vars, val env, val sequential,
-                           val *env_out, val ret_new_bindings,
-                           val ctx)
+                           val ret_new_bindings, val ctx)
 {
   val iter;
   struct bindings_helper_vars v;
@@ -1358,11 +1357,8 @@ static val bindings_helper(val vars, val env, val sequential,
     }
   }
 
-  if (env_out)
-    *env_out = v.ne;
-
   uw_pop_frame(&uw_cc);
-  return new_bindings;
+  return v.ne;
 }
 
 static val fbindings_helper(val vars, val env, val lbind, val ctx)
@@ -1403,9 +1399,11 @@ static val op_let(val form, val env)
   val args = rest(form);
   val vars = first(args);
   val body = rest(args);
-  val new_env;
-  (void) bindings_helper(vars, env, eq(let, let_star_s), &new_env, nil, form);
-  return eval_progn(body, new_env, form);
+  val saved_de = dyn_env;
+  val new_env = bindings_helper(vars, env, eq(let, let_star_s), nil, form);
+  val ret = eval_progn(body, new_env, form);
+  dyn_env = saved_de;
+  return ret;
 }
 
 static val op_fbind(val form, val env)
@@ -1418,6 +1416,18 @@ static val op_fbind(val form, val env)
   return eval_progn(body, new_env, form);
 }
 
+static val op_dvbind(val form, val env)
+{
+  val args = rest(form);
+  val sym = pop(&args);
+  val initform = pop(&args);
+  val initval = eval(initform, env, form);
+  val de = make_env(nil, nil, dyn_env);
+  env_vbind(de, sym, initval);
+  dyn_env = de;
+  return unbound_s;
+}
+
 static val get_bindings(val vars, val env)
 {
   list_collect_decl (out, iter);
@@ -2948,8 +2958,7 @@ static val me_equot(val form, val menv)
   return rlcp(cons(quote_s, cons(expand(cadr(form), menv), nil)), form);
 }
 
-static val expand_vars(val vars, val menv, val form,
-                       val *pspecials, int seq_p)
+static val expand_vars(val vars, val menv, val form, int seq_p)
 {
   val sym;
 
@@ -2961,30 +2970,39 @@ static val expand_vars(val vars, val menv, val form,
     return vars;
   } else if (symbolp(sym = car(vars))) {
     val rest_vars = rest(vars);
-    val rest_vars_ex = expand_vars(rest_vars, menv, form, pspecials, seq_p);
+    val rest_vars_ex = expand_vars(rest_vars, menv, form, seq_p);
     if (special_var_p(sym))
-      push(sym, pspecials);
-    if (rest_vars == rest_vars_ex)
+      sym = list(sym, list(dvbind_s, sym, nil, nao), nao);
+    else if (rest_vars == rest_vars_ex)
       return vars;
     return rlcp(cons(sym, rest_vars_ex), vars);
-  } else {
-    cons_bind (var, init, sym);
+  } else if (consp(sym)) {
+    val stuff = sym;
+    val var = pop(&stuff);
+    val init = pop(&stuff);
     val rest_vars = rest(vars);
     /* This var's init form sees a previous symbol macro whose name is
        the same as the variable, so menv is used. */
-    val init_ex = rlcp(expand_forms(init, menv), init);
+    val init_ex = rlcp(expand(init, menv), init);
     /* The initforms of subsequent vars in a sequential binding
        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,
-                                        pspecials, seq_p),
+    val rest_vars_ex = rlcp(expand_vars(rest_vars, menv_new, form, seq_p),
                             rest_vars);
 
-    if (special_var_p(var))
-      push(var, pspecials);
-    if (init == init_ex && rest_vars == rest_vars_ex)
+    if (stuff)
+      eval_warn(form, lit("extra forms in var-init pair ~s"), sym, nao);
+
+    if (special_var_p(var) && (atom(init_ex) || car(init_ex) != dvbind_s ||
+                               cadr(init_ex) != var))
+    {
+      init_ex = rlcp(list(dvbind_s, var, init_ex, nao), init_ex);
+    } else if (init == init_ex && rest_vars == rest_vars_ex) {
       return vars;
-    return rlcp(cons(cons(var, init_ex), rest_vars_ex), vars);
+    }
+    return rlcp(cons(cons(var, cons(init_ex, nil)), rest_vars_ex), vars);
+  } else {
+    eval_error(form, lit("variable binding expected, not ~s"), sym, nao);
   }
 }
 
@@ -3657,18 +3675,10 @@ 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 = 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)) {
+      val vars_ex = expand_vars(vars, menv, form, seq_p);
+      if (body == body_ex && vars == vars_ex)
         return form;
-      } else if (!specials || have_rebinds) {
-        return rlcp(cons(sym, cons(vars_ex, body_ex)), form);
-      } else {
-        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);
-      }
+      return rlcp(cons(sym, cons(vars_ex, body_ex)), form);
     } else if (sym == each_op_s) {
       val args = rest(form);
       val eachsym = first(args);
@@ -3802,7 +3812,8 @@ 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 || sym == with_dyn_rebinds_s) {
+    } else if (sym == quote_s || sym == fun_s || sym == with_dyn_rebinds_s ||
+               sym == dvbind_s) {
       return form;
     } else if (sym == for_op_s) {
       val vars = second(form);
@@ -4923,6 +4934,7 @@ void eval_init(void)
   flet_s = intern(lit("flet"), user_package);
   labels_s = intern(lit("labels"), user_package);
   call_s = intern(lit("call"), user_package);
+  dvbind_s = intern(lit("dvbind"), system_package);
   handler_bind_s = intern(lit("handler-bind"), user_package);
   cond_s = intern(lit("cond"), user_package);
   caseq_s = intern(lit("caseq"), user_package);
@@ -5045,6 +5057,7 @@ void eval_init(void)
   reg_op(let_star_s, op_let);
   reg_op(fbind_s, op_fbind);
   reg_op(lbind_s, op_fbind);
+  reg_op(dvbind_s, op_dvbind);
   reg_op(lambda_s, op_lambda);
   reg_op(fun_s, op_fun);
   reg_op(cond_s, op_cond);