* lib.c (assert_s): New global variable.

(obj_init): Intern assert symbol, store in assert_s.

* lib.h (assert_s): Declared.

* match.c (typed_error, v_assert, h_assert): New static functions.
(dir_tables_init): Register v_assert and h_assert.
Register assert_s as non-data-matching directive.

* unwind.c (uw_init): Register assert as a subtype
of error.

* txr.1: Describe assert.

6 files changed, 148 insertions, 11 deletions

diff --git a/ChangeLog b/ChangeLog
index 301ef5d9..e6df860d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,21 @@
 2014-03-06  Kaz Kylheku  <kaz@kylheku.com>
 
+	* lib.c (assert_s): New global variable.
+	(obj_init): Intern assert symbol, store in assert_s.
+
+	* lib.h (assert_s): Declared.
+
+	* match.c (typed_error, v_assert, h_assert): New static functions.
+	(dir_tables_init): Register v_assert and h_assert.
+	Register assert_s as non-data-matching directive.
+
+	* unwind.c (uw_init): Register assert as a subtype
+	of error.
+
+	* txr.1: Describe assert.
+
+2014-03-06  Kaz Kylheku  <kaz@kylheku.com>
+
 	* match.c: (v_next): Set the "curfile" in the context to "env" when
 	scanning environment.
 	(open_data_source): Regression: was not setting c->curfile when opening
diff --git a/lib.c b/lib.c
index 08d324c5..4365c4b8 100644
--- a/lib.c
+++ b/lib.c
@@ -83,7 +83,7 @@ val define_s, output_s, single_s, first_s, last_s, empty_s;
 val repeat_s, rep_s, flatten_s, forget_s;
 val local_s, merge_s, bind_s, rebind_s, cat_s;
 val try_s, catch_s, finally_s, throw_s, defex_s, deffilter_s;
-val eof_s, eol_s;
+val eof_s, eol_s, assert_s;
 val error_s, type_error_s, internal_error_s;
 val numeric_error_s, range_error_s;
 val query_error_s, file_error_s, process_error_s;
@@ -5204,6 +5204,7 @@ static void obj_init(void)
   query_error_s = intern(lit("query_error"), user_package);
   file_error_s = intern(lit("file_error"), user_package);
   process_error_s = intern(lit("process_error"), user_package);
+  assert_s = intern(lit("assert"), user_package);
 
   args_k = intern(lit("args"), keyword_package);
   nothrow_k = intern(lit("nothrow"), keyword_package);
diff --git a/lib.h b/lib.h
index e62eec93..ab519088 100644
--- a/lib.h
+++ b/lib.h
@@ -337,7 +337,7 @@ extern val define_s, output_s, single_s, first_s, last_s, empty_s;
 extern val repeat_s, rep_s, flatten_s, forget_s;
 extern val local_s, merge_s, bind_s, rebind_s, cat_s;
 extern val try_s, catch_s, finally_s, throw_s, defex_s, deffilter_s;
-extern val eof_s, eol_s;
+extern val eof_s, eol_s, assert_s;
 extern val error_s, type_error_s, internal_error_s;
 extern val numeric_error_s, range_error_s;
 extern val query_error_s, file_error_s, process_error_s;
diff --git a/match.c b/match.c
index 69baad5d..f3f7a642 100644
--- a/match.c
+++ b/match.c
@@ -112,6 +112,20 @@ static void file_err(val form, val fmt, ...)
   abort();
 }
 
+static void typed_error(val type, val form, val fmt, ...)
+{
+  va_list vl;
+  val stream = make_string_output_stream();
+
+  va_start (vl, fmt);
+  if (form)
+    format(stream, lit("(~a) "), source_loc_str(form), nao);
+  (void) vformat(stream, fmt, vl);
+  va_end (vl);
+
+  uw_throw(type, get_string_from_stream(stream));
+  abort();
+}
 
 static void dump_shell_string(const wchar_t *str)
 {
@@ -3562,6 +3576,37 @@ static val v_require(match_files_ctx *c)
   return next_spec_k;
 }
 
+static val v_assert(match_files_ctx *c)
+{
+  spec_bind (specline, first_spec, c->spec);
+
+  if (rest(specline))
+    return decline_k;
+
+  c->spec = rest(c->spec);
+
+  if (!c->spec)
+    return cons(c->bindings, cons(c->data, c->data_lineno));
+
+  {
+    val args = rest(first_spec);
+    val type = pop(&args);
+    val result = match_files(*c);
+
+    if (result) {
+      return result;
+    } else if (type) {
+      val values = mapcar(curry_123_2(func_n3(txeval_allow_ub), 
+                                      specline, c->bindings), args);
+      uw_throw(type, values);
+    } else {
+      if (c->curfile)
+        typed_error(assert_s, first_spec, lit("assertion (at ~s:~s)"), c->curfile, c->data_lineno, nao);
+      typed_error(assert_s, first_spec, lit("assertion (line ~s)"), c->data_lineno, nao);
+    }
+  }
+  abort();
+}
 
 static val v_load(match_files_ctx *c)
 {
@@ -3651,6 +3696,26 @@ static val h_do(match_line_ctx *c)
   return next_spec_k;
 }
 
+static val h_assert(match_line_ctx *c)
+{
+  val elem = rest(first(c->specline));
+  val type = pop(&elem);
+  val result = match_line(ml_specline(*c, rest(c->specline)));
+
+  if (result) {
+    return result;
+  } else if (type) {
+    val values = mapcar(curry_123_2(func_n3(txeval_allow_ub), 
+                                    c->specline, c->bindings), elem);
+    uw_throw(type, values);
+  } else {
+    if (c->file)
+      typed_error(assert_s, elem, lit("assertion (at ~s:~s)"), c->file, c->data_lineno, nao);
+    typed_error(assert_s, elem, lit("assertion (line ~s)"), c->data_lineno, nao);
+  }
+  abort();
+}
+
 static void open_data_source(match_files_ctx *c)
 {
   /* c->data == t is set up by the top level call to match_files.
@@ -3954,6 +4019,7 @@ static void dir_tables_init(void)
   sethash(v_directive_table, eof_s, cptr((mem_t *) v_eof));
   sethash(v_directive_table, do_s, cptr((mem_t *) v_do));
   sethash(v_directive_table, require_s, cptr((mem_t *) v_require));
+  sethash(v_directive_table, assert_s, cptr((mem_t *) v_assert));
   sethash(v_directive_table, load_s, cptr((mem_t *) v_load));
   sethash(v_directive_table, close_s, cptr((mem_t *) v_close));
 
@@ -3981,6 +4047,7 @@ static void dir_tables_init(void)
   sethash(h_directive_table, eol_s, cptr((mem_t *) h_eol));
   sethash(h_directive_table, do_s, cptr((mem_t *) h_do));
   sethash(h_directive_table, require_s, cptr((mem_t *) hv_trampoline));
+  sethash(h_directive_table, assert_s, cptr((mem_t *) h_assert));
 
   sethash(non_matching_directive_table, block_s, t);
   sethash(non_matching_directive_table, accept_s, t);
@@ -4001,6 +4068,7 @@ static void dir_tables_init(void)
   sethash(non_matching_directive_table, deffilter_s, t);
   sethash(non_matching_directive_table, filter_s, t);
   sethash(non_matching_directive_table, require_s, t);
+  sethash(non_matching_directive_table, assert_s, t);
   sethash(non_matching_directive_table, do_s, t);
   sethash(non_matching_directive_table, load_s, t);
   sethash(non_matching_directive_table, close_s, t);
diff --git a/txr.1 b/txr.1
index 59969354..29f4d576 100644
--- a/txr.1
+++ b/txr.1
@@ -1354,6 +1354,11 @@ Special clauses within @(try). See EXCEPTIONS below.
 .IP "@(defex), @(throw)"
 Define custom exception types; throw an exception.  See EXCEPTIONS below.
 
+.IP @(assert)
+The assert directive requires the following material to match, otherwise
+it throws an exception. It is useful for catching mistakes or omissions
+in parts of a query that are sure-fire matches.
+
 .IP @(flatten)
 Normalizes a set of specified variables to one-dimensional lists. Those
 variables which have scalar value are reduced to lists of that value.
@@ -1418,7 +1423,6 @@ The require directive is similar to the do directive: it evaluates one or more
 TXR Lisp expressions.  If the result of the rightmost expression is nil,
 then require triggers a match failure.  See the TXR LISP section far below.
 
-
 .PP
 
 .SH INPUT SCANNING AND DATA MANIPULATION
@@ -4777,6 +4781,53 @@ definitions are in error:
   @(defex x y)
   @(defex y x)@# error: circularity; y is already a supertype of x.
 
+.SS The Assert directive
+
+The assert directive requires the remaining query or sub-query which follows it
+to match. If the remainder fails to match, the assert directive throws an
+exception. If the directive is simply
+
+  @(assert)
+
+Then it throws an assertion of type assert, which is a subtype of error.
+The assert directive also takes arguments similar to the throw
+directive. The following assert directive, if it triggers, will throw
+an exception of type foo, with arguments 1 and "2".
+
+  @(assert foo 1 "2")
+
+The throw directive generates an exception. A type must be specified,
+followed by optional arguments.
+
+Example:
+
+  @(collect)
+  Important Header
+  ----------------
+  @(assert)
+  Foo: @a, @b
+  @(end)
+
+Without the assertion in places, if the "Foo: @a, @b" part does not
+match, then the entire interior of the @(collect) clause fails,
+and the collect continues searching for another match.
+
+With the assertion in place, if the "Important Header" and its
+underline match, then the remainder of the collect body must
+match, otherwise an exception is thrown. Now the program will not
+silently skip over any Important Header sections due to a problem
+in its matching logic. This is particularly useful when the matching is varied
+with numerous cases, and they must all be handled.
+
+There is a horizontal directive also. For instance:
+
+  abc@(assert)d@x
+
+asserts that if the prefix "abc" is matched, then it must be
+followed by a successful match for "d@x", or else an exception
+is thrown.
+
+
 .SH TXR LISP
 
 The TXR language contains an embedded Lisp dialect called TXR Lisp.
@@ -4814,19 +4865,19 @@ Bind variable b to the standard input stream:
 
 Define several Lisp functions using @(do):
 
-@(do 
-  (defun add (x y) (+ x y))
+  @(do 
+    (defun add (x y) (+ x y))
 
-  (defun occurs (item list)
-    (cond ((null list) nil)
-          ((atom list) (eql item list))
-          (t (or (eq (first list) item)
-                 (occurs item (rest list)))))))
+    (defun occurs (item list)
+      (cond ((null list) nil)
+            ((atom list) (eql item list))
+            (t (or (eq (first list) item)
+                   (occurs item (rest list)))))))
 
 Trigger a failure unless previously bound variable "answer" is greater
 than 42:
 
-@(require (> (str-int answer) 42)
+  @(require (> (str-int answer) 42)
 
 .SS Overview
 
diff --git a/unwind.c b/unwind.c
index fc703fc3..8c2fb676 100644
--- a/unwind.c
+++ b/unwind.c
@@ -432,4 +432,5 @@ void uw_init(void)
   uw_register_subtype(query_error_s, error_s);
   uw_register_subtype(file_error_s, error_s);
   uw_register_subtype(process_error_s, error_s);
+  uw_register_subtype(assert_s, error_s);
 }