From 491d594929405dd79e020f68138a10dc9ac10ae7 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Fri, 10 Feb 2017 15:32:17 -0800
Subject: 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.
---
 unwind.c | 18 ++++++------------
 1 file changed, 6 insertions(+), 12 deletions(-)

(limited to 'unwind.c')

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);
 }
-- 
cgit v1.2.3