Error reports trace through layers of macroexpansion.

* eval.c (error_trace): New function. Consolidates
error reporting between unhandled exception handling
in uw_throw, and the catcher in the repl.
(op_defmacro, expand_macrolet): Propagate location info from
body to wrapping block, and to the macro binding. In the
latter function, also to the body that is wrapped by local
macros.
(do_expand, macroexpand_1): Propagate location info from macro
expander to expansion, only taking it from the form if the
macro doesn't supply it.

* eval.h (error_trace): Declared.

* parser.c (repl): Replace error reporting code with call to
error_trace.

* unwind.c (uw_throw): uw_throw: likewise.

4 files changed, 63 insertions, 60 deletions

diff --git a/eval.c b/eval.c
index e7996c73..25a099fa 100644
--- a/eval.c
+++ b/eval.c
@@ -195,6 +195,51 @@ val lookup_origin(val form)
   return gethash(origin_hash, form);
 }
 
+void error_trace(val exsym, val exvals, val out_stream, val prefix)
+{
+  val last = last_form_evaled;
+  val info = source_loc_str(last, nil);
+  val ex_info = source_loc_str(last_form_expanded, nil);
+
+  if (cdr(exvals) || !stringp(car(exvals)))
+    format(out_stream, lit("~a exception args: ~!~s\n"),
+           prefix, exvals, nao);
+  else
+    format(out_stream, lit("~a ~!~a\n"), prefix, car(exvals), nao);
+
+  if (info && exsym != eval_error_s) {
+    val first = t;
+
+    while (last) {
+      val origin = lookup_origin(last);
+      val oinfo = source_loc_str(origin, nil);
+
+      if (first) {
+        if (origin)
+          format(out_stream, lit("~a possibly triggered by form ~!~s\n"),
+                 prefix, last, nao);
+        else
+          format(out_stream, lit("~a possibly triggered at ~a by form ~!~s\n"),
+                 prefix, info, last, nao);
+        first = nil;
+      }
+
+      if (origin)
+        format(out_stream, lit("~a ... an expansion at ~a of ~!~s\n"),
+               prefix, info, origin, nao);
+      else
+        format(out_stream, lit("~a which is located at ~a\n"), prefix, info, nao);
+
+      last = origin;
+      info = oinfo;
+    }
+  }
+
+  if (ex_info)
+    format(out_stream, lit("~a during expansion at ~a of form ~!~s\n"),
+           prefix, ex_info, last_form_expanded, nao);
+}
+
 val lookup_global_var(val sym)
 {
   uses_or2;
@@ -1474,7 +1519,7 @@ static val op_defmacro(val form, val env)
   val name = first(args);
   val params = second(args);
   val body = rest(rest(args));
-  val block = cons(block_s, cons(name, body));
+  val block = rlcp(cons(block_s, cons(name, body)), body);
 
   if (!bindable(name))
     eval_error(form, lit("defmacro: ~s is not a bindable symbol"), name, nao);
@@ -1484,7 +1529,9 @@ static val op_defmacro(val form, val env)
 
   remhash(top_fb, name);
   /* defmacro captures lexical environment, so env is passed */
-  sethash(top_mb, name, cons(name, cons(env, cons(params, cons(block, nil)))));
+  sethash(top_mb, name,
+          rlcp_tree(cons(name, cons(env, cons(params, cons(block, nil)))),
+                    block));
   if (eval_initing)
     sethash(builtin, name, defmacro_s);
   return name;
@@ -1495,7 +1542,6 @@ static val expand_macro(val form, val expander, val menv)
   if (cobjp(expander)) {
     mefun_t fp = coerce(mefun_t, cptr_get(expander));
     val expanded = fp(form, menv);
-    sethash(origin_hash, expanded, form);
     return expanded;
   } else {
     debug_enter;
@@ -1576,7 +1622,7 @@ static val expand_macrolet(val form, val menv)
     val name = pop(&macro);
     val params = expand_params(pop(&macro), menv);
     val macro_ex = expand_forms(macro, menv);
-    val block = cons(block_s, cons(name, macro_ex));
+    val block = rlcp_tree(cons(block_s, cons(name, macro_ex)), macro_ex);
 
     builtin_reject_test(op, name, form);
 
@@ -1584,10 +1630,11 @@ static val expand_macrolet(val form, val menv)
      * so they can be treated uniformly. The nil after the name is
      * the ordinary lexical environment: a macrolet doesn't capture that.
      */
-    env_fbind(new_env, name, cons(nil, cons(params, cons(block, nil))));
+    rlcp_tree(env_fbind(new_env, name,
+              cons(nil, cons(params, cons(block, nil)))), block);
   }
 
-  return maybe_progn(expand_forms(body, new_env));
+  return rlcp_tree(maybe_progn(expand_forms(body, new_env)), body);
 }
 
 static val expand_symacrolet(val form, val menv)
@@ -3304,7 +3351,7 @@ tail:
       val mac_expand = expand_macro(form, macro, menv);
       if (mac_expand == form)
         return form;
-      form = rlcp_tree(mac_expand, form);
+      form = rlcp_tree(rlcp_tree(mac_expand, macro), form);
       goto tail;
     } else if (sym == progn_s) {
       val args = rest(form);
@@ -3373,14 +3420,14 @@ static val macroexpand_1(val form, val menv)
     val mac_expand = expand_macro(form, macro, menv);
     if (mac_expand == form)
       return form;
-    return rlcp_tree(mac_expand, form);
+    return rlcp_tree(rlcp_tree(mac_expand, macro), form);
   }
 
   if (bindable(form) && (macro = lookup_symac(menv, form))) {
     val mac_expand = cdr(macro);
     if (mac_expand == form)
       return form;
-    return rlcp_tree(mac_expand, form);
+    return rlcp_tree(mac_expand, macro);
   }
 
   return form;
diff --git a/eval.h b/eval.h
index 78a0f8b0..06bae699 100644
--- a/eval.h
+++ b/eval.h
@@ -32,6 +32,7 @@ extern val last_form_evaled, last_form_expanded;
 
 noreturn val eval_error(val form, val fmt, ...);
 val lookup_origin(val form);
+void error_trace(val exsym, val exvals, val out_stream, val prefix);
 val make_env(val fbindings, val vbindings, val up_env);
 val copy_env(val oenv);
 val env_fbind(val env, val sym, val fun);
diff --git a/parser.c b/parser.c
index c3c581e4..ec59399d 100644
--- a/parser.c
+++ b/parser.c
@@ -49,6 +49,7 @@
 #include "stream.h"
 #include "y.tab.h"
 #include "sysif.h"
+#include "cadr.h"
 #include "parser.h"
 #if HAVE_TERMIOS
 #include "linenoise/linenoise.h"
@@ -751,31 +752,7 @@ val repl(val bindings, val in_stream, val out_stream)
       if (uw_exception_subtype_p(exsym, syntax_error_s)) {
         put_line(lit("** syntax error"), out_stream);
       } else if (uw_exception_subtype_p(exsym, error_s)) {
-        val info = source_loc_str(last_form_evaled, nil);
-        val ex_info = source_loc_str(last_form_expanded, nil);
-        val origin = last_form_evaled;
-
-        if (cdr(exvals))
-          format(out_stream, lit("** ~!~a ~!~s\n"),
-                 car(exvals), cdr(exvals), nao);
-        else
-          format(out_stream, lit("** ~!~a\n"), car(exvals), nao);
-
-        if (info && exsym != eval_error_s) {
-          format(out_stream, lit("** possibly triggered at ~a by form ~!~s\n"),
-                 info, last_form_evaled, nao);
-
-          while ((origin = lookup_origin(origin))) {
-            val oinfo = source_loc_str(origin, lit("(n/a)"));
-            format(out_stream, lit("** which is an expansion at ~a of ~!~s\n"),
-                   oinfo, origin, nao);
-          }
-        }
-
-        if (ex_info)
-          format(out_stream, lit("** during expansion at ~a of form ~!~s\n"),
-                 ex_info, last_form_expanded, nao);
-
+        error_trace(exsym, exvals, std_error, lit("**"));
       } else {
         format(out_stream, lit("** ~!~s exception, args: ~!~s\n"),
                exsym, exvals, nao);
diff --git a/unwind.c b/unwind.c
index 866a6c4b..b0dc2518 100644
--- a/unwind.c
+++ b/unwind.c
@@ -531,34 +531,12 @@ val uw_throw(val sym, val args)
     }
 
     if (opt_loglevel >= 1) {
-      val is_msg = and2(stringp(car(args)), null(cdr(args)));
-      val msg_or_args = if3(is_msg, car(args), args);
-      val info = source_loc_str(last_form_evaled, nil);
-      val ex_info = source_loc_str(last_form_expanded, nil);
-      val origin = last_form_evaled;
-      format(std_error, lit("~a: unhandled exception of type ~a:\n"),
-             prog_string, sym, nao);
-
-      if (info && sym != eval_error_s) {
-        format(std_error, lit("~a: possibly triggered at ~a by form ~!~s\n"),
-               prog_string, info, last_form_evaled, nao);
-
-        while ((origin = lookup_origin(origin))) {
-          val oinfo = source_loc_str(origin, lit("(n/a)"));
-          format(std_error, lit("~a: which is an expansion at ~a of ~!~s\n"),
-                 prog_string, oinfo, origin, nao);
-        }
-      }
+      val prefix = format(nil, lit("~a:"), prog_string, nao);
 
-      if (ex_info)
-        format(std_error, lit("~a: during expansion at ~a of form ~!~s\n"),
-               prog_string, ex_info, last_form_expanded, nao);
+      format(std_error, lit("~a unhandled exception of type ~a:\n"),
+             prefix, sym, nao);
 
-      format(std_error,
-             if3(is_msg,
-                 lit("~a: message: ~!~a\n"),
-                 lit("~a: exception args: ~!~s\n")),
-             prog_string, msg_or_args, nao);
+      error_trace(sym, args, std_error, prefix);
     }
     if (uw_exception_subtype_p(sym, query_error_s) ||
         uw_exception_subtype_p(sym, file_error_s)) {