Use non-hacky representation for deferrable warnings.

Deferrable warnings now get their own subtype, defr-warning.
The tag is a regular argument: no funny dotted argument list.

* eval.c (eval_defr_warn): Throw new style deferrable warning.
(me_op, no_warn_expand): Catch defr-warning rather than
warning. Use uw_muffle_warning to suppress it.
(gather_free_refs): Parse new representation of deferrable
warning.
(expand_with_free_refs): Catch defr-warning rather than
warning.

* lib.c (defr_warning_s): New symbol variable defined.
(obj_init): Initialize defr_warning_s.

* lib.h (defr_warning_s): Declared.

* share/txr/stdlib/error.tl (compile-defr-warning): Throw
new-style deferrable warning.

* unwind.c (uw_muffle_deferrable_warning): Function removed.
(uw_throw): Bugfix: handle warnings by checking by subtype
rather than exactly for the warning type. Distinguish
deferrable warnings by subtype rather than argument list
shape.
(uw_defer_warning): Take the new style args and reconstruct
the (msg . tag) representation for a deferred warning, so
the other functions don't have to change.
(uw_late_init): Register defr-warning as exception subtype
of warning.

* unwind.h (uw_muffle_deferrable_warning): Decl removed.

* txr.1: Adjusted all documentation touching on the subject
of the representation of deferrable warnings.

7 files changed, 69 insertions, 46 deletions

diff --git a/eval.c b/eval.c
index 08a3f851..a8622d69 100644
--- a/eval.c
+++ b/eval.c
@@ -278,7 +278,8 @@ static val eval_defr_warn(val ctx, val tag, val fmt, ...)
 
     (void) vformat(stream, fmt, vl);
 
-    uw_throw(warning_s, cons(get_string_from_stream(stream), tag));
+    uw_throw(defr_warning_s,
+             cons(get_string_from_stream(stream), cons(tag, nil)));
   }
 
   uw_catch(exsym, exvals) { (void) exsym; (void) exvals; }
@@ -3439,8 +3440,8 @@ static val me_op(val form, val menv)
   cons_bind (sym, body, form);
   uw_frame_t uw_handler;
   val new_menv = make_var_shadowing_env(menv, cons(rest_s, nil));
-  val body_ex = (uw_push_handler(&uw_handler, cons(warning_s, nil),
-                                 func_n1v(uw_muffle_deferrable_warning)),
+  val body_ex = (uw_push_handler(&uw_handler, cons(defr_warning_s, nil),
+                                 func_n1v(uw_muffle_warning)),
                  if3(sym == op_s,
                     expand_forms_lisp1(body, new_menv),
                     expand(body, new_menv)));
@@ -4315,8 +4316,8 @@ static val no_warn_expand(val form, val menv)
 {
   val ret;
   uw_frame_t uw_handler;
-  uw_push_handler(&uw_handler, cons(warning_s, nil),
-                  func_n1v(uw_muffle_deferrable_warning));
+  uw_push_handler(&uw_handler, cons(defr_warning_s, nil),
+                  func_n1v(uw_muffle_warning));
   ret = expand(form, menv);
   uw_pop_frame(&uw_handler);
   return ret;
@@ -4326,15 +4327,17 @@ static val gather_free_refs(val info_cons, val exc, struct args *args)
 {
   (void) exc;
 
+  args_normalize(args, 2);
+
   if (args_count(args) == 2) {
-    val sym = args_get_rest(args, 2);
     val tag = args_at(args, 1);
+    cons_bind (kind, sym, tag);
 
-    if (tag == var_s) {
+    if (kind == var_s) {
       loc al = car_l(info_cons);
       if (!memq(sym, deref(al)))
         mpush(sym, al);
-    } else if (tag == fun_s) {
+    } else if (kind == fun_s) {
       loc dl = cdr_l(info_cons);
       if (!memq(sym, deref(dl)))
         mpush(sym, dl);
@@ -4360,11 +4363,11 @@ static val expand_with_free_refs(val form, val menv_in, val upto_menv_in)
   uw_frame_t uw_handler;
   val info_cons_free = cons(nil, nil);
   val info_cons_bound = cons(nil, nil);
-  uw_push_handler(&uw_handler, cons(warning_s, nil),
+  uw_push_handler(&uw_handler, cons(defr_warning_s, nil),
                   func_f1v(info_cons_free, gather_free_refs));
   ret = expand(form, menv);
   uw_pop_frame(&uw_handler);
-  uw_push_handler(&uw_handler, cons(warning_s, nil),
+  uw_push_handler(&uw_handler, cons(defr_warning_s, nil),
                   func_f1v(info_cons_bound, gather_free_refs_nw));
   (void) expand(ret,
                 squash_menv_deleting_range(menv, upto_menv));
diff --git a/lib.c b/lib.c
index 92c7c027..8720218d 100644
--- a/lib.c
+++ b/lib.c
@@ -101,7 +101,8 @@ val eof_s, eol_s, assert_s, name_s;
 val error_s, type_error_s, internal_error_s, panic_s;
 val numeric_error_s, range_error_s;
 val query_error_s, file_error_s, process_error_s, syntax_error_s;
-val timeout_error_s, system_error_s, warning_s, restart_s, continue_s;
+val timeout_error_s, system_error_s;
+val warning_s, defr_warning_s, restart_s, continue_s;
 val gensym_counter_s, nullify_s, from_list_s, lambda_set_s;
 
 val nothrow_k, args_k, colon_k, auto_k, fun_k;
@@ -9484,6 +9485,7 @@ static void obj_init(void)
   timeout_error_s = intern(lit("timeout-error"), user_package);
   assert_s = intern(lit("assert"), user_package);
   warning_s = intern(lit("warning"), user_package);
+  defr_warning_s = intern(lit("defr-warning"), user_package);
   restart_s = intern(lit("restart"), user_package);
   continue_s = intern(lit("continue"), user_package);
   name_s = intern(lit("name"), user_package);
diff --git a/lib.h b/lib.h
index 6e25710d..d58a5091 100644
--- a/lib.h
+++ b/lib.h
@@ -441,7 +441,8 @@ extern val eof_s, eol_s, assert_s, name_s;
 extern val error_s, type_error_s, internal_error_s, panic_s;
 extern val numeric_error_s, range_error_s;
 extern val query_error_s, file_error_s, process_error_s, syntax_error_s;
-extern val system_error_s, timeout_error_s, warning_s, restart_s, continue_s;
+extern val timeout_error_s, system_error_s;
+extern val warning_s, defr_warning_s, restart_s, continue_s;
 extern val gensym_counter_s;
 
 #define gensym_counter (deref(lookup_var_l(nil, gensym_counter_s)))
diff --git a/share/txr/stdlib/error.tl b/share/txr/stdlib/error.tl
index f437f863..f0876ef1 100644
--- a/share/txr/stdlib/error.tl
+++ b/share/txr/stdlib/error.tl
@@ -45,5 +45,5 @@
   (let ((loc (sys:loc ctx))
         (name (sys:ctx-name ctx)))
     (catch
-      (throw 'warning (fmt `@loc~s: @fmt` name . args) . tag)
+      (throw 'defr-warning (fmt `@loc~s: @fmt` name . args)  tag)
       (continue ()))))
diff --git a/txr.1 b/txr.1
index ff1b8e7d..7e14e11c 100644
--- a/txr.1
+++ b/txr.1
@@ -33976,16 +33976,21 @@ The generation of a warning thus conforms to the following pattern:
 
 \*(TX supports a form of diagnostic known as a
 .IR "deferrable warning" .
-A deferrable warning, like an ordinary warning, is an exception of type
-.code warning
-or subtyped from that type. It is distinguished from a regular
-warning by the presence of additional argument material after
-the exception message. Specifically, a deferrable exception
-is thrown according to this pattern:
+A deferrable warning is distinguished in two ways. Firstly, it is
+either of the type
+.code defr-warning
+or subtyped from that type. The
+.code defr-warning
+type itself is a direct subtype of
+.codn warning .
+
+Secondly, a deferrable warning carries an additional tag argument after the
+exception message. A deferrable exception is thrown according to
+this pattern:
 
 .cblk
   (catch
-    (throw 'warning "message" . tag)
+    (throw 'defr-warning "message" . tag)
     (continue ()))
 .cble
 
@@ -33997,7 +34002,7 @@ is searched for the presence of the tag, using
 equality. If the tag is found, then the warning is discarded.
 If the tag is not found, then the exception argument list is added
 to the global
-.IR "deferred exception list" .
+.IR "deferred warning list" .
 In either case,
 the
 .code continue
@@ -34011,8 +34016,11 @@ superfluous if a definition of that function is supplied later,
 yet before that function call is executed.
 
 Deferred warnings accumulate in the deferred warning list
-from which they can be removed. The list is displays at
-various times such as when a top-level load completes.
+from which they can be removed. The list is purged at various
+times such as when a top-level load completes, and the
+deferred warnings are released, as if by a call to the
+.code release-deferred-warnings
+function.
 
 .coNP Functions @ compile-error and @ compile-warning
 .synb
@@ -34065,13 +34073,28 @@ and its
 .desc
 The
 .code compile-defr-warning
-is very similar to
-.codn compile-warning .
-The difference is that it features a
+function throws an exception of type
+.code defr-warning
+and internally provides the expected
+.code catch
+for the
+.code continue
+exception needed to resume after the warning.
+
+The function produces a diagnostic message which
+incorporates the location information and symbol
+obtained from
+.meta context-obj
+and the
+.codn format -style
+arguments
+.meta fmt-string
+and its
+.metn fmt-arg -s.
+This diagnostic message constitutes the first
+argument of the exception. The
 .meta tag
-parameter whose argument it incorporates into the
-.code warning
-exception to mark it as a deferrable warning.
+argument is taken as the second argument.
 
 .coNP Function @ purge-deferred-warning
 .synb
@@ -34192,10 +34215,11 @@ deferrable warnings, and prints ordinary warnings:
 .cblk
   (handle
     (some-form ..) ;; some code which might generate warnings
-    (warning (msg . args)
-      (if (car args)
-        (defer-warning (cons msg args)) ;; tag present: defer
-        (put-line `warning: @msg`)) ;; print immediately
+    (defr-warning (msg tag) ;; catch deferrable and defer
+      (defer-warning (cons msg tag))
+      (throw 'continue)) ;; warning processed: resume execution
+    (warning (msg)
+      (put-line `warning: @msg`) ;; print non-deferrable
       (throw 'continue))) ;; warning processed: resume execution
 .cble
 
diff --git a/unwind.c b/unwind.c
index d3697456..cbbdf70a 100644
--- a/unwind.c
+++ b/unwind.c
@@ -429,14 +429,6 @@ val uw_muffle_warning(val exc, struct args *args)
   uw_throw(continue_s, nil);
 }
 
-val uw_muffle_deferrable_warning(val exc, struct args *args)
-{
-  (void) exc;
-  if (args_count(args) == 2)
-    uw_throw(continue_s, nil);
-  return nil;
-}
-
 void uw_push_cont_copy(uw_frame_t *fr, mem_t *ptr,
                        void (*copy)(mem_t *ptr, int parent))
 {
@@ -587,9 +579,9 @@ val uw_throw(val sym, val args)
       abort();
     }
 
-    if (sym == warning_s) {
+    if (uw_exception_subtype_p(sym, warning_s)) {
       --reentry_count;
-      if (cdr(args))
+      if (uw_exception_subtype_p(sym, defr_warning_s))
         uw_defer_warning(args);
       else
         format(std_error, lit("warning: ~a\n"), car(args), nao);
@@ -685,9 +677,10 @@ val type_mismatch(val fmt, ...)
 
 val uw_defer_warning(val args)
 {
-  val tag = cdr(args);
+  val msg = car(args);
+  val tag = cadr(args);
   if (!memqual(tag, tentative_defs))
-    push(args, &deferred_warnings);
+    push(cons(msg, tag), &deferred_warnings);
   return nil;
 }
 
@@ -1087,4 +1080,5 @@ void uw_late_init(void)
           func_n3o(uw_capture_cont, 2));
   uw_register_subtype(continue_s, restart_s);
   uw_register_subtype(warning_s, t);
+  uw_register_subtype(defr_warning_s, warning_s);
 }
diff --git a/unwind.h b/unwind.h
index aeac00d6..7f8cec02 100644
--- a/unwind.h
+++ b/unwind.h
@@ -151,7 +151,6 @@ val uw_find_frame(val extype, val frtype);
 val uw_find_frames(val extype, val frtype);
 val uw_invoke_catch(val catch_frame, val sym, struct args *);
 val uw_muffle_warning(val exc, struct args *);
-val uw_muffle_deferrable_warning(val exc, struct args *);
 val uw_capture_cont(val tag, val fun, val ctx_form);
 void uw_push_cont_copy(uw_frame_t *, mem_t *ptr,
                        void (*copy)(mem_t *ptr, int parent));