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.

1 files changed, 13 insertions, 10 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));