summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2017-02-10 15:32:17 -0800
committerKaz Kylheku <kaz@kylheku.com>2017-02-10 15:32:17 -0800
commit491d594929405dd79e020f68138a10dc9ac10ae7 (patch)
tree616d9d8116e7212e2b016bf0977b2872824cc674
parent39655edfb062034a76c0b880bf810d14d9047baa (diff)
downloadtxr-491d594929405dd79e020f68138a10dc9ac10ae7.tar.gz
txr-491d594929405dd79e020f68138a10dc9ac10ae7.tar.bz2
txr-491d594929405dd79e020f68138a10dc9ac10ae7.zip
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.
-rw-r--r--eval.c23
-rw-r--r--lib.c4
-rw-r--r--lib.h3
-rw-r--r--share/txr/stdlib/error.tl2
-rw-r--r--txr.164
-rw-r--r--unwind.c18
-rw-r--r--unwind.h1
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));