summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--eval.c45
-rw-r--r--lib.c7
-rw-r--r--lib.h1
-rw-r--r--txr.135
4 files changed, 88 insertions, 0 deletions
diff --git a/eval.c b/eval.c
index 2d547d44..2c8490d7 100644
--- a/eval.c
+++ b/eval.c
@@ -5222,6 +5222,48 @@ static val me_l1_setq(val form, val menv)
}
}
+static val rt_assert_fail(val file, val line, val expr,
+ val fmt, struct args *args)
+{
+ val str_stream = make_string_output_stream();
+
+ if (!missingp(fmt)) {
+ if (line && file) {
+ format(str_stream, lit("assertion ~s failed in ~a:~a: "),
+ expr, file, line, nao);
+ } else {
+ format(str_stream, lit("assertion ~s failed: "), expr, nao);
+ }
+ formatv(str_stream, fmt, args);
+ } else {
+ if (line && file) {
+ format(str_stream, lit("assertion ~s failed in ~a:~a\n"),
+ expr, file, line, nao);
+ } else {
+ format(str_stream, lit("assertion ~s failed"), expr, nao);
+ }
+ }
+
+ uw_throw(assert_s, get_string_from_stream(str_stream));
+ return nil;
+}
+
+static val me_assert(val form, val menv)
+{
+ cons_bind (line, file, source_loc(form));
+ val extra_args = cddr(form);
+ val rt_assert_fail = intern(lit("rt-assert-fail"), system_package);
+
+ (void) menv;
+
+ return list(or_s, cadr(form),
+ apply_frob_args(list(rt_assert_fail, file, line,
+ list(quote_s, cadr(form), nao),
+ extra_args, nao)),
+ nao);
+}
+
+
static val return_star(val name, val retval)
{
uw_block_return(name, retval);
@@ -6466,6 +6508,7 @@ void eval_init(void)
reg_mac(intern(lit("mlet"), user_package), func_n2(me_mlet));
reg_mac(load_time_s, func_n2(me_load_time));
reg_mac(intern(lit("load-for"), user_package), func_n2(me_load_for));
+ reg_mac(intern(lit("assert"), user_package), func_n2(me_assert));
reg_fun(cons_s, func_n2(cons));
reg_fun(intern(lit("make-lazy-cons"), user_package),
@@ -7037,6 +7080,8 @@ void eval_init(void)
reg_fun(intern(lit("rt-pprof"), system_package), func_n1(rt_pprof));
reg_fun(intern(lit("rt-load-for"), system_package), func_n0v(rt_load_for));
+ reg_fun(intern(lit("rt-assert-fail"), system_package), func_n4ov(rt_assert_fail, 3));
+
eval_error_s = intern(lit("eval-error"), user_package);
uw_register_subtype(eval_error_s, error_s);
diff --git a/lib.c b/lib.c
index cf25d99e..99720212 100644
--- a/lib.c
+++ b/lib.c
@@ -6265,6 +6265,13 @@ val func_n3ov(val (*fun)(val, val, val, varg), int reqargs)
return obj;
}
+val func_n4ov(val (*fun)(val, val, val, val, varg), int reqargs)
+{
+ val obj = func_n4v(fun);
+ obj->f.optargs = 4 - reqargs;
+ return obj;
+}
+
val func_interp(val env, val form)
{
val obj = make_obj();
diff --git a/lib.h b/lib.h
index c3330344..b3541b20 100644
--- a/lib.h
+++ b/lib.h
@@ -979,6 +979,7 @@ val func_n8o(val (*fun)(val, val, val, val, val, val, val, val), int reqargs);
val func_n1ov(val (*fun)(val, varg), int reqargs);
val func_n2ov(val (*fun)(val, val, varg), int reqargs);
val func_n3ov(val (*fun)(val, val, val, varg), int reqargs);
+val func_n4ov(val (*fun)(val, val, val, val, varg), int reqargs);
val func_interp(val env, val form);
val func_vm(val closure, val desc, int fixparam, int reqargs, int variadic);
val copy_fun(val ofun);
diff --git a/txr.1 b/txr.1
index a1a21800..99c354b2 100644
--- a/txr.1
+++ b/txr.1
@@ -42594,6 +42594,41 @@ The frame receives control even if it it is not otherwise eligible for
catching the exception type denoted by
.metn symbol .
+.coNP Macro @ assert
+.synb
+.mets (assert < expr >> [ format-string << format-arg *])
+.syne
+.desc
+The
+.code assert
+macro evaluates
+.metn expr .
+If
+.meta expr
+yields any true value, then
+.code assert
+terminates normally, and that value is returned.
+
+If instead
+.meta expr
+yields
+.codn nil ,
+then
+.code assert
+throws an exception of type
+.codn assert .
+The exception carries an informative character string that contains
+a diagnostic detailing the expression which yielded
+.codn nil ,
+and the source location of that expression, if available.
+
+If the
+.meta format-string
+and possibly additional format arguments are given to
+.code assert
+then those arguments are used to format additional text which is appended to
+the diagnostic message after a separating character such as a colon.
+
.SS* Static Error Diagnosis
This section describes a number of features related to the diagnosis