New assert macro.

* eval.c (rt_assert_fail, me_assert): New static functions.
(eval_init): assert macro and sys:rt-assert-fail function
registered.

* lib.c (func_n4ov): New function.

* lib.h (func_n4ov): Declared.

* txr.1: Documented.

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