diff options
author | Kaz Kylheku <kaz@kylheku.com> | 2021-08-18 06:51:44 -0700 |
---|---|---|
committer | Kaz Kylheku <kaz@kylheku.com> | 2021-08-18 06:51:44 -0700 |
commit | ca59be500904f84f5b138257cc152e1ec6764819 (patch) | |
tree | 9736456339f67f3ecede8394dc336d444168fb77 | |
parent | 4911b99c3a255155931248669da0546ca7c005d3 (diff) | |
download | txr-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.c | 39 | ||||
-rw-r--r-- | stdlib/doc-syms.tl | 6 | ||||
-rw-r--r-- | txr.1 | 72 |
3 files changed, 116 insertions, 1 deletions
@@ -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") @@ -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 |