From 636ad323c664f292802316c2da93767e9332f731 Mon Sep 17 00:00:00 2001 From: Kaz Kylheku Date: Sun, 20 Jul 2014 20:04:28 -0700 Subject: * 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. --- ChangeLog | 12 +++++++++++ eval.c | 72 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++------ txr.1 | 52 +++++++++++++++++++++++++++++++++++++++++++++ 3 files changed, 130 insertions(+), 6 deletions(-) diff --git a/ChangeLog b/ChangeLog index 970b8825..90346146 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,15 @@ +2014-07-20 Kaz Kylheku + + * 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 * eval.c (eval_init): Register juxt as intrinsic. diff --git a/eval.c b/eval.c index dc344da1..4e6f8009 100644 --- a/eval.c +++ b/eval.c @@ -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)); diff --git a/txr.1 b/txr.1 index ca0d5529..1de29b62 100644 --- a/txr.1 +++ b/txr.1 @@ -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 * []) + (caseql * []) + (caseqqual * []) + +.TP +Description: + +These three macros arrange for the evaluation of of , whose value +is then compared against the key or keys in each in turn. +When the value matches a key, then the remaining forms of +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 then the next is tested. +If all these clauses are exhausted, and there is no , +then the value nil is returned. Otherwise, the forms in the +are evaluated, and the value of the last one is returned. + +The syntax of a takes on these two forms: + + (
*) + +where 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 . The form (t) may be used as a key to match that symbol. + +The syntax of an is: + + (t *) + +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 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 -- cgit v1.2.3