diff options
| -rw-r--r-- | ChangeLog | 12 | ||||
| -rw-r--r-- | eval.c | 72 | ||||
| -rw-r--r-- | txr.1 | 52 |
3 files changed, 130 insertions, 6 deletions
@@ -1,5 +1,17 @@ 2014-07-20 Kaz Kylheku <kaz@kylheku.com> + * eval.c (caseq_s, caseql_s, casequal_s, memq_s, memql_s, memqual_s, + eq_s, eql_s, equal_s): New symbol variables. + (me_case): New static function. + (eval_init): Initialize new variables. Register caseq, caseql and + casequal macros. + Re-register memq, memql, memqual, eq, eql and equal using + new symbol variables. + + * txr.1: Document case, caseql and casequal. + +2014-07-20 Kaz Kylheku <kaz@kylheku.com> + * eval.c (eval_init): Register juxt as intrinsic. * lib.c (do_juxt): New static function. @@ -72,6 +72,9 @@ val dyn_env; val eval_error_s; val dwim_s, progn_s, prog1_s, let_s, let_star_s, lambda_s, call_s; val cond_s, if_s, defvar_s, defun_s, defmacro_s, tree_case_s, tree_bind_s; +val caseq_s, caseql_s, casequal_s; +val memq_s, memql_s, memqual_s; +val eq_s, eql_s, equal_s; val inc_s, dec_s, push_s, pop_s, flip_s, gethash_s, car_s, cdr_s, not_s; val del_s, vecref_s; val for_s, for_star_s, each_s, each_star_s, collect_each_s, collect_each_star_s; @@ -2558,6 +2561,51 @@ static val me_flet_labels(val form, val menv) cons(lambdas, body)); } +static val me_case(val form, val menv) +{ + val form_orig = form; + val casesym = pop(&form); + val testform = pop(&form); + val tformsym = gensym(lit("test-")); + val memfuncsym, eqfuncsym; + list_collect_decl (condpairs, ptail); + + if (casesym == caseq_s) { + memfuncsym = memq_s; + eqfuncsym = eq_s; + } else if (casesym == caseql_s) { + memfuncsym = memql_s; + eqfuncsym = eql_s; + } else { + memfuncsym = memqual_s; + eqfuncsym = equal_s; + } + + for (; consp(form); form = cdr(form)) { + cons_bind (clause, rest, form); + cons_bind (keys, forms, clause); + + if (!rest && keys == t) { + ptail = list_collect(ptail, clause); + break; + } + + if (keys == t) + eval_error(form_orig, lit("~s: symbol t used as key"), casesym, nao); + + ptail = list_collect(ptail, + cons(list(if3(atom(keys), eqfuncsym, memfuncsym), + tformsym, keys, nao), + forms)); + } + + if (form && atom(form)) + eval_error(form_orig, lit("~s: improper form terminated by ~s"), casesym, form, nao); + + return list(let_s, cons(list(tformsym, testform, nao), nil), + cons(cond_s, condpairs), nao); +} + static val expand_catch_clause(val form, val menv) { val sym = first(form); @@ -3369,6 +3417,15 @@ void eval_init(void) labels_s = intern(lit("labels"), user_package); call_s = intern(lit("call"), user_package); cond_s = intern(lit("cond"), user_package); + caseq_s = intern(lit("caseq"), user_package); + caseql_s = intern(lit("caseql"), user_package); + casequal_s = intern(lit("casequal"), user_package); + memq_s = intern(lit("memq"), user_package); + memql_s = intern(lit("memql"), user_package); + memqual_s = intern(lit("memqual"), user_package); + eq_s = intern(lit("eq"), user_package); + eql_s = intern(lit("eql"), user_package); + equal_s = intern(lit("equal"), user_package); if_s = intern(lit("if"), user_package); defvar_s = intern(lit("defvar"), user_package); defun_s = intern(lit("defun"), user_package); @@ -3496,6 +3553,9 @@ void eval_init(void) reg_mac(quasilist_s, me_quasilist); reg_mac(flet_s, me_flet_labels); reg_mac(labels_s, me_flet_labels); + reg_mac(caseq_s, me_case); + reg_mac(caseql_s, me_case); + reg_mac(casequal_s, me_case); reg_fun(cons_s, func_n2(cons)); reg_fun(intern(lit("make-lazy-cons"), user_package), func_n1(make_lazy_cons)); @@ -3555,9 +3615,9 @@ void eval_init(void) reg_fun(intern(lit("flatten"), user_package), func_n1(flatten)); reg_fun(intern(lit("flatten*"), user_package), func_n1(lazy_flatten)); reg_fun(intern(lit("tuples"), user_package), func_n3o(tuples, 2)); - reg_fun(intern(lit("memq"), user_package), func_n2(memq)); - reg_fun(intern(lit("memql"), user_package), func_n2(memql)); - reg_fun(intern(lit("memqual"), user_package), func_n2(memqual)); + reg_fun(memq_s, func_n2(memq)); + reg_fun(memql_s, func_n2(memql)); + reg_fun(memqual_s, func_n2(memqual)); reg_fun(intern(lit("member"), user_package), func_n4o(member, 2)); reg_fun(intern(lit("member-if"), user_package), func_n3o(member_if, 2)); reg_fun(intern(lit("remq"), user_package), func_n2(remq)); @@ -3584,9 +3644,9 @@ void eval_init(void) reg_fun(intern(lit("all"), user_package), func_n3o(all_satisfy, 1)); reg_fun(intern(lit("none"), user_package), func_n3o(none_satisfy, 1)); reg_fun(intern(lit("multi"), user_package), func_n1v(multi)); - reg_fun(intern(lit("eq"), user_package), eq_f); - reg_fun(intern(lit("eql"), user_package), eql_f); - reg_fun(intern(lit("equal"), user_package), equal_f); + reg_fun(eq_s, eq_f); + reg_fun(eql_s, eql_f); + reg_fun(equal_s, equal_f); reg_fun(plus_s = intern(lit("+"), user_package), func_n0v(plusv)); reg_fun(intern(lit("-"), user_package), func_n1v(minusv)); @@ -5711,6 +5711,58 @@ If the first form of a group yields nil, then processing continues with the next group, if any. If all form groups yield nil, then the cond form yields nil. This holds in the case that the syntax is empty: (cond) yields nil. +.SS Macros caseq, caseql and casequal + +.TP +Syntax: + + (caseq <test-form> <normal-clause>* [<else-clause>]) + (caseql <test-form> <normal-clause>* [<else-clause>]) + (caseqqual <test-form> <normal-clause>* [<else-clause>]) + +.TP +Description: + +These three macros arrange for the evaluation of of <test-form>, whose value +is then compared against the key or keys in each <normal-clause> in turn. +When the value matches a key, then the remaining forms of <normal-clause> +are evaluated, and the value of the last form is returned; subsequent +clauses are not evaluated. When the value doesn't match any of the keys +of a <normal-clause> then the next <normal-clause> is tested. +If all these clauses are exhausted, and there is no <else-clause>, +then the value nil is returned. Otherwise, the forms in the <else-clause> +are evaluated, and the value of the last one is returned. + +The syntax of a <normal-clause> takes on these two forms: + + (<key> <form>*) + +where <key> may be an atom which denotes a single key, or else a list +of keys. There is a restriction that the symbol t may not be used +as <key>. The form (t) may be used as a key to match that symbol. + +The syntax of an <else-clause> is: + + (t <form>*) + +which resembles a form that is often used as the final clause +in the cond syntax. + +The three forms of the case construct differ from what type of +test they apply between the value of <test-form> and the keys. +The caseq macro generates code which uses the eq function's +equality. The caseql macro uses eql, and casequal uses equal. + +.TP +Example: + + (let ((command-symbol (casequal command-string + (("q" "quit") 'quit) + (("a" "add") 'add) + (("d" "del" "delete") 'delete) + (t 'unknown)))) + ...) + .SS Macros when and unless .TP |