errors: avoid premature release of deferred warnings.

We don't want to be unconditionally releasing deferred
warnings when error exceptions occur in evaluation or
compilation. The reason is that the error might be handled,
for instance by a speculative expansion. Then unwanted noise
occurs, because deferred warnings have been released
prematurely.

* eval.c (eval_exception): Do not call
uw_release_deferred_warnings here.
(error_trace): But do call uw_release_deferred_warnings here,
before printing anything else. We want to preserve the
behavior that when error information is actually being
printed to a stream, any deferred warnings are dumped first
because they might pertain to the error. (I may revisit
this requirement; perhaps deferred warnings rarely, if ever,
pertain to an error).

* share/txr/stdlib/error.tl (compile-error): Do not dump
deferred warnings unconditionally. Only dump them if we
are also printing the error message to stderr. Secondly, do
not output the error message at all, unless there is no
handler for the error.

2 files changed, 5 insertions, 4 deletions

diff --git a/eval.c b/eval.c
index 7b3f1ad6..2ad82dec 100644
--- a/eval.c
+++ b/eval.c
@@ -298,8 +298,6 @@ static void eval_exception(val sym, val ctx, val fmt, va_list vl)
 
   (void) vformat(stream, fmt, vl);
 
-  uw_release_deferred_warnings();
-
   uw_rthrow(sym, get_string_from_stream(stream));
 }
 
@@ -393,6 +391,8 @@ void error_trace(val exsym, val exvals, val out_stream, val prefix)
   val xlast = uw_last_form_expanded();
   val info = source_loc_str(last, nil);
 
+  uw_dump_deferred_warnings(out_stream);
+
   if (cdr(exvals) || !stringp(car(exvals)))
     format(out_stream, lit("~a exception args: ~!~s\n"),
            prefix, exvals, nao);
diff --git a/share/txr/stdlib/error.tl b/share/txr/stdlib/error.tl
index a7885c3f..7f70391e 100644
--- a/share/txr/stdlib/error.tl
+++ b/share/txr/stdlib/error.tl
@@ -38,9 +38,10 @@
   (let* ((nctx (sys:dig ctx))
          (loc (sys:loc nctx))
          (name (sys:ctx-name nctx)))
-    (dump-deferred-warnings *stderr*)
     (let ((msg (fmt `@loc: ~s: @fmt` name . args)))
-      (when *load-recursive*
+      (when (and *load-recursive*
+                 (null (find-frame 'error 'catch-frame)))
+        (dump-deferred-warnings *stderr*)
         (put-line msg *stderr*))
       (throw 'eval-error msg))))