summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorKaz Kylheku <kaz@kylheku.com>2021-08-18 06:51:44 -0700
committerKaz Kylheku <kaz@kylheku.com>2021-08-18 06:51:44 -0700
commitca59be500904f84f5b138257cc152e1ec6764819 (patch)
tree9736456339f67f3ecede8394dc336d444168fb77
parent4911b99c3a255155931248669da0546ca7c005d3 (diff)
downloadtxr-ca59be500904f84f5b138257cc152e1ec6764819.tar.gz
txr-ca59be500904f84f5b138257cc152e1ec6764819.tar.bz2
txr-ca59be500904f84f5b138257cc152e1ec6764819.zip
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.
-rw-r--r--eval.c39
-rw-r--r--stdlib/doc-syms.tl6
-rw-r--r--txr.172
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