diff options
| -rw-r--r-- | ChangeLog | 16 | ||||
| -rw-r--r-- | lib.c | 3 | ||||
| -rw-r--r-- | lib.h | 2 | ||||
| -rw-r--r-- | match.c | 68 | ||||
| -rw-r--r-- | txr.1 | 69 | ||||
| -rw-r--r-- | unwind.c | 1 |
6 files changed, 148 insertions, 11 deletions
@@ -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 @@ -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); @@ -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; @@ -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); @@ -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 @@ -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); } |