debugger: expand frames.

This patch adds special unwind frames for backtracing
expansions. With this, we can get rid of the global variable
last_form_expanded, since to get the last form expanded, we
just search for the most enclosing expand frame.

* eval.c (last_form_expanded): Global variable removed.
(error_trace): Use uw_last_form_expanded() instead of
last_form_expanded.
(expand_eval): No need to save and restore
last_form_expanded any more.
(expand_lisp_setq, expand_setqf, expand_lisp1, do_expand): Use
uw_last_form_expanded().
(expand, do_macroexpand_1): Push and pop expand frame.
This fixes a bug: do_macroexpand_1 was not recording
last_form_expanded. Evaluation of top-level forms uses
explicit macroexpansion, therefore top-level evaluation was
neglecting to set last_form_expanded.
This explains weird behavior I saw in the listener from
time to time, when errors would report against the expansion
of the wrong form.
(eval_init): Remove reference to last_form_expanded variable.

* eval.h (last_form_expanded): Declaration removed.

* share/txr/stdlib/debug.tl (expand-frame print-trace,
expand-frame loc): New methods.
(print-backtrace): Include uw-expand frames in the backtrace.

* unwind.c (expand_frame_type): New static variable.
(uw_find_frames_by_mask): Handle UW_EXPAND.
(uw_last_form_expanded, uw_push_expand): New functions.
(uw_late_init): Register expand-frame struct type.

* unwind.h (enum uw_frtype): New enum member, UW_EXPAND.
(uw_last_form_expanded, uw_push_expand): Declared.

5 files changed, 93 insertions, 37 deletions

diff --git a/eval.c b/eval.c
index 43e499d8..1435c0d1 100644
--- a/eval.c
+++ b/eval.c
@@ -106,7 +106,7 @@ val eval_only_s, compile_only_s;
 val special_s, unbound_s;
 val whole_k, form_k, symacro_k;
 
-val last_form_evaled, last_form_expanded;
+val last_form_evaled;
 
 val call_f;
 
@@ -359,6 +359,7 @@ val set_last_form_evaled(val form)
 void error_trace(val exsym, val exvals, val out_stream, val prefix)
 {
   val last = last_form_evaled;
+  val xlast = uw_last_form_expanded();
   val info = source_loc_str(last, nil);
 
   if (cdr(exvals) || !stringp(car(exvals)))
@@ -401,23 +402,23 @@ void error_trace(val exsym, val exvals, val out_stream, val prefix)
     }
   }
 
-  if (last_form_expanded) {
-    val ex_info = source_loc_str(last_form_expanded, nil);
-    val form = last_form_expanded;
+  if (xlast) {
+    val ex_info = source_loc_str(xlast, nil);
+    val form = xlast;
 
     if (ex_info)
       format(out_stream, lit("~a during expansion at ~a of form ~!~s\n"),
-             prefix, ex_info, last_form_expanded, nao);
+             prefix, ex_info, xlast, nao);
     else
       format(out_stream, lit("~a during expansion of form ~!~s\n"),
-             prefix, last_form_expanded, nao);
+             prefix, xlast, nao);
 
     if (info)
       format(out_stream, lit("~a by macro code located at ~a\n"), prefix,
              info, nao);
 
     for (;;) {
-      val origin = lookup_origin(form);
+      val origin = lookup_origin(xlast);
       val oinfo = source_loc_str(origin, nil);
 
       if (origin) {
@@ -1433,13 +1434,11 @@ val funcall_interp(val interp_fun, struct args *args)
 static val expand_eval(val form, val env)
 {
   val lfe_save = last_form_evaled;
-  val lfx_save = last_form_expanded;
-  val form_ex = (last_form_expanded = last_form_evaled = nil,
+  val form_ex = (last_form_evaled = nil,
                  expand(form, nil));
   val loading = cdr(lookup_var(dyn_env, load_recursive_s));
   val ret = ((void) (loading || uw_release_deferred_warnings()),
              eval(form_ex, default_null_arg(env), form));
-  last_form_expanded = lfx_save;
   last_form_evaled = lfe_save;
   return ret;
 }
@@ -2389,7 +2388,7 @@ static val expand_lisp1_setq(val form, val menv)
         eval_error(form, lit("~s: misapplied to form ~s"),
                    op, sym, nao);
       if (!lookup_var(nil, sym) && !lookup_fun(nil, sym))
-        eval_defr_warn(last_form_expanded,
+        eval_defr_warn(uw_last_form_expanded(),
                        cons(var_s, sym),
                        lit("~s: unbound variable/function ~s"),
                        op, sym, nao);
@@ -2421,7 +2420,7 @@ static val expand_setqf(val form, val menv)
       eval_error(form, lit("~s: cannot assign lexical function ~s"), op, sym, nao);
 
     if (!lookup_fun(nil, sym))
-      eval_defr_warn(last_form_expanded,
+      eval_defr_warn(uw_last_form_expanded(),
                      cons(fun_s, sym), lit("~s: unbound function ~s"),
                      op, sym, nao);
 
@@ -3310,7 +3309,7 @@ tail:
         !uw_tentative_def_exists(cons(var_s, form)) &&
         !uw_tentative_def_exists(cons(fun_s, form)))
     {
-      eval_defr_warn(last_form_expanded,
+      eval_defr_warn(uw_last_form_expanded(),
                      cons(sym_s, form),
                      lit("unbound variable/function ~s"), form, nao);
     }
@@ -4535,7 +4534,7 @@ again:
       return expand(rlcp_tree(symac, form), menv);
     }
     if (!lookup_var(menv, form))
-      eval_defr_warn(last_form_expanded,
+      eval_defr_warn(uw_last_form_expanded(),
                      cons(var_s, form),
                      lit("unbound variable ~s"), form, nao);
     return form;
@@ -4710,13 +4709,13 @@ again:
       }
       if (!lookup_fun(menv, arg)) {
         if (special_operator_p(arg))
-          eval_warn(last_form_expanded,
+          eval_warn(uw_last_form_expanded(),
                     lit("fun used on special operator ~s"), arg, nao);
         else if (!bindable(arg))
-          eval_warn(last_form_expanded,
+          eval_warn(uw_last_form_expanded(),
                     lit("~s appears in operator position"), arg, nao);
         else
-          eval_defr_warn(last_form_expanded,
+          eval_defr_warn(uw_last_form_expanded(),
                          cons(fun_s, arg),
                          lit("unbound function ~s"),
                          arg, nao);
@@ -4876,10 +4875,10 @@ again:
         insym_ex = expand(insym, menv);
       } else if (!lookup_fun(menv, sym) && !special_operator_p(sym)) {
         if (!bindable(sym))
-          eval_warn(last_form_expanded,
+          eval_warn(uw_last_form_expanded(),
                     lit("~s appears in operator position"), sym, nao);
         else
-          eval_defr_warn(last_form_expanded,
+          eval_defr_warn(uw_last_form_expanded(),
                          cons(fun_s, sym),
                          lit("unbound function ~s"),
                          sym, nao);
@@ -4909,16 +4908,19 @@ again:
 val expand(val form, val menv)
 {
   val ret = nil;
-  val lfe_save = last_form_expanded;
+#if CONFIG_DEBUG_SUPPORT
+  uw_frame_t expand_fr;
+  uw_push_expand(&expand_fr, form, menv);
+#endif
 
-  if (consp(form))
-    last_form_expanded = form;
   ret = do_expand(form, menv);
-  last_form_expanded = lfe_save;
 
   if (!lookup_origin(ret))
     set_origin(ret, form);
 
+#if CONFIG_DEBUG_SUPPORT
+  uw_pop_frame(&expand_fr);
+#endif
   return ret;
 }
 
@@ -5000,23 +5002,26 @@ val macro_form_p(val form, val menv)
 static val do_macroexpand_1(val form, val menv, val (*lookup)(val, val))
 {
   val macro;
+#if CONFIG_DEBUG_SUPPORT
+  uw_frame_t expand_fr;
+  uw_push_expand(&expand_fr, form, menv);
+#endif
 
   menv = default_null_arg(menv);
 
   if (consp(form) && (macro = lookup_mac(menv, car(form)))) {
     val mac_expand = expand_macro(form, macro, menv);
-    if (mac_expand == form)
-      return form;
-    return rlcp_tree(rlcp_tree(mac_expand, form), macro);
-  }
-
-  if (bindable(form) && (macro = lookup(menv, form))) {
+    if (mac_expand != form)
+      form = rlcp_tree(rlcp_tree(mac_expand, form), macro);
+  } else if (bindable(form) && (macro = lookup(menv, form))) {
     val mac_expand = cdr(macro);
-    if (mac_expand == form)
-      return form;
-    return rlcp_tree(mac_expand, macro);
+    if (mac_expand != form)
+      form = rlcp_tree(mac_expand, macro);
   }
 
+#if CONFIG_DEBUG_SUPPORT
+  uw_pop_frame(&expand_fr);
+#endif
   return form;
 }
 
@@ -6112,7 +6117,7 @@ void eval_init(void)
   val length_f = func_n1(length);
 
   protect(&top_vb, &top_fb, &top_mb, &top_smb, &special, &builtin, &dyn_env,
-          &op_table, &pm_table, &last_form_evaled, &last_form_expanded,
+          &op_table, &pm_table, &last_form_evaled,
           &call_f, &unbound_s, &origin_hash, convert(val *, 0));
   top_fb = make_hash(t, nil, nil);
   top_vb = make_hash(t, nil, nil);
diff --git a/eval.h b/eval.h
index c538941e..f61968f9 100644
--- a/eval.h
+++ b/eval.h
@@ -30,7 +30,7 @@ extern val hash_lit_s, hash_construct_s, struct_lit_s, qref_s, uref_s;
 extern val eval_error_s, if_s, call_s;
 extern val eq_s, eql_s, equal_s;
 extern val car_s, cdr_s;
-extern val last_form_evaled, last_form_expanded;
+extern val last_form_evaled;
 extern val load_path_s, load_recursive_s;
 extern val special_s, struct_s;
 
diff --git a/share/txr/stdlib/debugger.tl b/share/txr/stdlib/debugger.tl
index 8eeb9ce2..26f30741 100644
--- a/share/txr/stdlib/debugger.tl
+++ b/share/txr/stdlib/debugger.tl
@@ -78,6 +78,15 @@
                  ^[,(cadr form)]
                  ^(,sym)))))))
 
+(defmeth expand-frame print-trace (fr pr-fr nx-fr prefix)
+  (let* ((form fr.form)
+         (loc (source-loc-str form)))
+    (put-string `@prefix X:@(if loc `(@loc):`)`)
+    (prinl form)))
+
+(defmeth expand-frame loc (fr)
+  (source-loc-str fr.form))
+
 (defun print-backtrace (: (*stdout* *stdout*) (prefix ""))
   (with-resources ((imode (set-indent-mode *stdout* indent-foff)
                           (set-indent-mode *stdout* imode))
@@ -86,7 +95,7 @@
                    (length (set-max-length *stdout* 10)
                            (set-max-length *stdout* length)))
     (window-map 1 nil (lambda (pr el nx) el.(print-trace pr nx prefix))
-                (find-frames-by-mask (logior uw-fcall uw-eval)))))
+                (find-frames-by-mask (logior uw-fcall uw-eval uw-expand)))))
 
 (defun debugger ()
   (with-disabled-debugging
diff --git a/unwind.c b/unwind.c
index 48852dbc..ca8762fd 100644
--- a/unwind.c
+++ b/unwind.c
@@ -67,7 +67,7 @@ static val sys_cont_s, sys_cont_poison_s;
 static val sys_cont_free_s, sys_capture_cont_s;
 
 static val frame_type, catch_frame_type, handle_frame_type;
-static val fcall_frame_type, eval_frame_type;
+static val fcall_frame_type, eval_frame_type, expand_frame_type;
 
 static val deferred_warnings, tentative_defs;
 
@@ -440,6 +440,13 @@ val uw_find_frames_by_mask(val mask_in)
           slotset(frame, env_s, fr->el.env);
           break;
         }
+      case UW_EXPAND:
+        {
+          frame = allocate_struct(expand_frame_type);
+          slotset(frame, form_s, fr->el.form);
+          slotset(frame, env_s, fr->el.env);
+          break;
+        }
       default:
         break;
       }
@@ -454,6 +461,22 @@ val uw_find_frames_by_mask(val mask_in)
 
 #endif
 
+#if CONFIG_DEBUG_SUPPORT
+
+val uw_last_form_expanded(void)
+{
+  uw_frame_t *fr;
+
+  for (fr = uw_stack; fr != 0; fr = fr->uw.up) {
+    if (fr->uw.type == UW_EXPAND)
+      return fr->el.form;
+  }
+
+  return nil;
+}
+
+#endif
+
 val uw_invoke_catch(val catch_frame, val sym, struct args *args)
 {
   uw_frame_t *ex, *ex_point;
@@ -593,6 +616,16 @@ void uw_push_eval(uw_frame_t *fr, val form, val env)
   uw_stack = fr;
 }
 
+void uw_push_expand(uw_frame_t *fr, val form, val env)
+{
+  memset(fr, 0, sizeof *fr);
+  fr->el.type = UW_EXPAND;
+  fr->el.form = form;
+  fr->el.env = env;
+  fr->el.up = uw_stack;
+  uw_stack = fr;
+}
+
 #endif
 
 static val exception_subtypes;
@@ -1184,6 +1217,10 @@ void uw_late_init(void)
                                      frame_type, nil,
                                      list(form_s, env_s, nao),
                                      nil, nil, nil, nil);
+  expand_frame_type = make_struct_type(intern(lit("expand-frame"), user_package),
+                                       frame_type, nil,
+                                       list(form_s, env_s, nao),
+                                       nil, nil, nil, nil);
 #endif
   reg_mac(intern(lit("defex"), user_package), func_n2(me_defex));
   reg_var(unhandled_hook_s = intern(lit("*unhandled-hook*"),
@@ -1220,6 +1257,7 @@ void uw_late_init(void)
   reg_varl(intern(lit("uw-guard"), system_package), num_fast(1U <<UW_GUARD));
   reg_varl(intern(lit("uw-fcall"), system_package), num_fast(1U <<UW_FCALL));
   reg_varl(intern(lit("uw-eval"), system_package), num_fast(1U <<UW_EVAL));
+  reg_varl(intern(lit("uw-expand"), system_package), num_fast(1U <<UW_EXPAND));
   reg_fun(intern(lit("find-frames-by-mask"), user_package), func_n1(uw_find_frames_by_mask));
 #endif
   uw_register_subtype(continue_s, restart_s);
diff --git a/unwind.h b/unwind.h
index 1a122ebd..30ab70c2 100644
--- a/unwind.h
+++ b/unwind.h
@@ -30,7 +30,7 @@ typedef enum uw_frtype {
   UW_BLOCK, UW_CAPTURED_BLOCK, UW_MENV, UW_CATCH, UW_HANDLE,
   UW_CONT_COPY, UW_GUARD,
 #if CONFIG_DEBUG_SUPPORT
-  UW_FCALL, UW_EVAL
+  UW_FCALL, UW_EVAL, UW_EXPAND
 #endif
 } uw_frtype_t;
 
@@ -146,6 +146,7 @@ void uw_push_handler(uw_frame_t *, val matches, val fun);
 #if CONFIG_DEBUG_SUPPORT
 void uw_push_fcall(uw_frame_t *, val fun, struct args *args);
 void uw_push_eval(uw_frame_t *, val form, val env);
+void uw_push_expand(uw_frame_t *, val form, val env);
 #endif
 noreturn val uw_throw(val sym, val exception);
 noreturn val uw_throwv(val sym, struct args *);
@@ -174,6 +175,9 @@ val uw_find_frame(val extype, val frtype);
 val uw_find_frames(val extype, val frtype);
 #if CONFIG_DEBUG_SUPPORT
 val uw_find_frames_by_mask(val mask);
+val uw_last_form_expanded(void);
+#else
+define uw_last_form_expanded() ((void) 0)
 #endif
 val uw_invoke_catch(val catch_frame, val sym, struct args *);
 val uw_muffle_warning(val exc, struct args *);