New ecase macros.

Even prior to discovering the recent defect in deffi, which
was caused by a missing case in caseql, combined with poor
testing, I was already thinking about adding ecase macros.
The introduction of must-match and must-match-case also shows
my motivation. That deffi bug convinced me to take action
and implement these.

* eval.c (case_error_s) New symbol variable.
(me_ecase): New static function.
(eval_init): Register new intrinsic macros ecaseq, ecaseql,
ecasequal, ecaseq*, ecaseql* and ecasequal*.
Intern case-error and initialize case_error_s.

* txr.1: Documented. Also updated Exception Hierarchy diagram
with match-error and case-error.

* stdlib/doc-syms.tl: Updated.

3 files changed, 116 insertions, 1 deletions

diff --git a/eval.c b/eval.c
index f2b65710..f36ca763 100644
--- a/eval.c
+++ b/eval.c
@@ -73,7 +73,7 @@ val top_vb, top_fb, top_mb, top_smb, special, builtin;
 val op_table, pm_table;
 val dyn_env;
 
-val eval_error_s;
+val eval_error_s, case_error_s;
 val dwim_s, progn_s, prog1_s, prog2_s, sys_blk_s;
 val let_s, let_star_s, lambda_s, call_s, dvbind_s;
 val sys_catch_s, handler_bind_s, cond_s, if_s, iflet_s, when_s, usr_var_s;
@@ -4289,6 +4289,34 @@ static val me_case(val form, val menv)
               cons(cond_s, condpairs), nao);
 }
 
+static val me_ecase(val form, val menv)
+{
+  val casesym = pop(&form);
+  val orig_args = form;
+  val testform = pop(&form);
+  val tgtsym = intern(cdr(symbol_name(casesym)), user_package);
+  val clauses = form;
+  val lastclause = car(lastcons(clauses));
+
+  if (consp(lastclause) && car(lastclause) == t) {
+    return cons(tgtsym, orig_args);
+  } else {
+    val nform = apply_frob_args(list(tgtsym,
+                                     testform,
+                                     append2(clauses,
+                                             cons(list(t, list(throw_s,
+                                                               list(quote_s,
+                                                                    case_error_s,
+                                                                    nao),
+                                                               lit("unhandled case"),
+                                                               nao),
+                                                       nao),
+                                                  nil)),
+                                     nao));
+    return me_case(nform, menv);
+  }
+}
+
 static val me_prog2(val form, val menv)
 {
   val arg1 = cadr(form);
@@ -6492,6 +6520,7 @@ void eval_init(void)
   val length_f = func_n1(length);
   val me_flet_labels_f = func_n2(me_flet_labels);
   val me_case_f = func_n2(me_case);
+  val me_ecase_f = func_n2(me_ecase);
   val me_iflet_whenlet_f = func_n2(me_iflet_whenlet);
   val me_while_until_f = func_n2(me_while_until);
   val me_while_until_star_f = func_n2(me_while_until_star);
@@ -6736,6 +6765,12 @@ void eval_init(void)
   reg_mac(caseq_star_s, me_case_f);
   reg_mac(caseql_star_s, me_case_f);
   reg_mac(casequal_star_s, me_case_f);
+  reg_mac(intern(lit("ecaseq"), user_package), me_ecase_f);
+  reg_mac(intern(lit("ecaseql"), user_package), me_ecase_f);
+  reg_mac(intern(lit("ecasequal"), user_package), me_ecase_f);
+  reg_mac(intern(lit("ecaseq*"), user_package), me_ecase_f);
+  reg_mac(intern(lit("ecaseql*"), user_package), me_ecase_f);
+  reg_mac(intern(lit("ecasequal*"), user_package), me_ecase_f);
   reg_mac(prog2_s, func_n2(me_prog2));
   reg_mac(intern(lit("tb"), user_package), func_n2(me_tb));
   reg_mac(intern(lit("tc"), user_package), func_n2(me_tc));
@@ -7330,7 +7365,9 @@ void eval_init(void)
   reg_fun(intern(lit("rt-assert-fail"), system_package), func_n4ov(rt_assert_fail, 3));
 
   eval_error_s = intern(lit("eval-error"), user_package);
+  case_error_s = intern(lit("case-error"), user_package);
   uw_register_subtype(eval_error_s, error_s);
+  uw_register_subtype(case_error_s, error_s);
 
   lisplib_init();
 }
diff --git a/stdlib/doc-syms.tl b/stdlib/doc-syms.tl
index d111995d..48eb6624 100644
--- a/stdlib/doc-syms.tl
+++ b/stdlib/doc-syms.tl
@@ -540,6 +540,12 @@
       ("ebadmsg" "N-036B1BDB")
       ("ebusy" "N-036B1BDB")
       ("ecanceled" "N-036B1BDB")
+      ("ecaseq" "N-03F13774")
+      ("ecaseq*" "N-03F13774")
+      ("ecaseql" "N-03F13774")
+      ("ecaseql*" "N-03F13774")
+      ("ecasequal" "N-03F13774")
+      ("ecasequal*" "N-03F13774")
       ("echild" "N-036B1BDB")
       ("echo" "N-0072FF5E")
       ("echoctl" "N-0072FF5E")
diff --git a/txr.1 b/txr.1
index 95031939..a5d884f3 100644
--- a/txr.1
+++ b/txr.1
@@ -16195,6 +16195,74 @@ macros as case keys.
   --> "cool"
 .brev
 
+.coNP Macros @, ecaseq @, ecaseql @, ecasequal @, ecaseq* @ ecaseql* and @ ecasequal*
+.synb
+.mets (ecaseq < test-form << normal-clause * <> [ else-clause ])
+.mets (ecaseql < test-form << normal-clause * <> [ else-clause ])
+.mets (ecasequal < test-form << normal-clause * <> [ else-clause ])
+.mets (ecaseq* < test-form << normal-clause * <> [ else-clause ])
+.mets (ecaseql* < test-form << normal-clause * <> [ else-clause ])
+.mets (ecasequal* < test-form << normal-clause * <> [ else-clause ])
+.syne
+.desc
+These macros are error-catching variants of, respectively,
+.codn caseq ,
+.codn caseql ,
+.codn casequal ,
+.codn caseq* ,
+.code caseql*
+and
+.cond casequal* .
+
+If the
+.meta else-clause
+is present in the invocation of an error-catching case macro, then the the
+invocation is precisely equivalent to the corresponding non-error-trapping
+variant.
+
+If the
+.meta else-clause
+is missing in the invocation of an error-catching variant, then a default
+.meta else-clause
+is inserted which throws an exception of type
+.codn case-error ,
+derived from
+.codn error .
+After this insertion, the semantics follows that of the non-error-trapping
+variant.
+
+For instance,
+.codn "(ecaseql 3)" ,
+which has no
+.metn else-clause ,
+is equivalent to
+.mono
+.meti (caseql 3 (t << expr ))
+.onom
+where
+.meta expr
+indicates the inserted expression which throws
+.codn case-error .
+However,
+.code "(ecaseql 3 (t 42))"
+is simply equivalent to
+.codn "(caseql 3 (t 42))" ,
+since it has an
+.metn else-clause .
+
+Note: the error-catching case macros are intended for situations in which it is
+a matter of program correctness that every possible value of
+.meta test-form
+matches a
+.metn normal-clause ,
+such that if a failure to match occurs, it indicates a software defect.
+The error-throwing
+.meta else-clause
+helps to ensure that the error situation is noticed.
+Without this clause, the case macro terminates with a value of
+.codn nil ,
+which may conceal the defect and delay its identification.
+
 .coNP Operator/function @ if
 .synb
 .mets (if < cond < t-form <> [ e-form ])
@@ -47409,6 +47477,10 @@ subtype of every exception type:
                       |
                       +--- eval-error
                       |
+                      +--- match-error
+                      |
+                      +--- case-error
+                      |
                       +--- opt-error
 .brev