Introduce case{q,ql,qual}* macros which eval keys.

* eval.c (caseq_star_s, caseql_star_s, casequal_star_s):
New symbol variables.
(me_case): Implement new macro semantics.
(eval_init): Initialize new symbol variables, and
register the symbols to the me_case macro expander.

* tests/sock-common.tl (local-addr): This function
depends on the old broken caseql semantics which
evaluate keys. Using caseql* makes it work again.

* txr.1: Document case{q,ql,qual}* macros.

3 files changed, 95 insertions, 4 deletions

diff --git a/eval.c b/eval.c
index e0c852b0..199bfa0a 100644
--- a/eval.c
+++ b/eval.c
@@ -80,6 +80,7 @@ val defvar_s, defvarl_s, defparm_s, defparml_s, defun_s, defmacro_s;
 val tree_case_s, tree_bind_s;
 val sys_mark_special_s;
 val caseq_s, caseql_s, casequal_s;
+val caseq_star_s, caseql_star_s, casequal_star_s;
 val memq_s, memql_s, memqual_s;
 val eq_s, eql_s, equal_s;
 val car_s, cdr_s, not_s, vecref_s;
@@ -3133,12 +3134,14 @@ static val me_case(val form, val menv)
   val tformsym = gensym(lit("test-"));
   val memfuncsym, eqfuncsym;
   val lofnil = cons(nil, nil);
+  val star = tnil(casesym == caseq_star_s || casesym == caseql_star_s ||
+                  casesym == casequal_star_s);
   list_collect_decl (condpairs, ptail);
 
-  if (casesym == caseq_s) {
+  if (casesym == caseq_s || casesym == caseq_star_s) {
     memfuncsym = memq_s;
     eqfuncsym = eq_s;
-  } else if (casesym == caseql_s) {
+  } else if (casesym == caseql_s || casesym == caseql_star_s) {
     memfuncsym = memql_s;
     eqfuncsym = eql_s;
   } else {
@@ -3158,7 +3161,14 @@ static val me_case(val form, val menv)
     if (keys == t)
       eval_error(form_orig, lit("~s: symbol t used as key"), casesym, nao);
 
-    if (opt_compat && opt_compat <= 156) {
+    if (star) {
+      if (atom(keys))
+        keys = eval(keys, nil, form);
+      else
+        keys = eval(cons(list_s, keys), nil, form);
+    }
+
+    if (opt_compat && opt_compat <= 156 && !star) {
       ptail = list_collect(ptail,
                            cons(list(if3(atom(keys), eqfuncsym, memfuncsym),
                                      tformsym,
@@ -4734,6 +4744,9 @@ void eval_init(void)
   caseq_s = intern(lit("caseq"), user_package);
   caseql_s = intern(lit("caseql"), user_package);
   casequal_s = intern(lit("casequal"), user_package);
+  caseq_star_s = intern(lit("caseq*"), user_package);
+  caseql_star_s = intern(lit("caseql*"), user_package);
+  casequal_star_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);
@@ -4910,6 +4923,9 @@ void eval_init(void)
   reg_mac(caseq_s, me_case);
   reg_mac(caseql_s, me_case);
   reg_mac(casequal_s, me_case);
+  reg_mac(caseq_star_s, me_case);
+  reg_mac(caseql_star_s, me_case);
+  reg_mac(casequal_star_s, me_case);
   reg_mac(intern(lit("tb"), user_package), me_tb);
   reg_mac(intern(lit("tc"), user_package), me_tc);
   reg_mac(opip_s, me_opip);
diff --git a/tests/sock-common.tl b/tests/sock-common.tl
index 63f31c83..8fed8f23 100644
--- a/tests/sock-common.tl
+++ b/tests/sock-common.tl
@@ -1,5 +1,5 @@
 (defun local-addr (family port)
-  (caseql family
+  (caseql* family
     (af-inet (new sockaddr-in addr inaddr-loopback port port))
     (af-inet6 (new sockaddr-in6 addr in6addr-loopback port port))))
 
diff --git a/txr.1 b/txr.1
index 1e6013ed..77a6f753 100644
--- a/txr.1
+++ b/txr.1
@@ -13243,6 +13243,81 @@ uses
     ...)
 .cble
 
+.coNP Macros @, caseq* @ caseql* and @ casequal*
+.synb
+.mets (caseq* < test-form << normal-clause * <> [ else-clause ])
+.mets (caseql* < test-form << normal-clause * <> [ else-clause ])
+.mets (casequal* < test-form << normal-clause * <> [ else-clause ])
+.syne
+.desc
+The
+.codn caseq* ,
+.codn caseql* ,
+and
+.code casequal*
+macros are similar to the macros
+.codn caseq ,
+.codn caseql ,
+and
+.codn casequal ,
+differing from them in only the following regard. The
+.metn normal-clause ,
+of these macros has the form
+.cblk
+.mets >> ( evaluated-key << form *)
+.cble
+where
+.code evaluated-key
+is either an atom, which is evaluated to produce a key, or else
+else a compound form, whose elements are evaluated as forms, producing
+multiple keys.  This evaluation takes place at macro-expansion time,
+in the dynamic environment.
+
+The
+.meta else-clause
+works the same way under these macros as under
+.code caseq
+.IR "et al" .
+
+Note that although in a
+.metn normal-clause ,
+.meta evaluated-key
+must not be the atom
+.codn t ,
+there is no restriction against it being
+an atom which evaluates to
+.code t.
+In this situation, the value
+.code t
+has no special meaning.
+
+The
+.meta evaluated-key
+expressions are evaluated in the order in which they appear in
+the construct, at the time the
+.codn caseq* ,
+.code caseql*
+or
+.code casequal*
+macro is expanded.
+
+Note: these macros allow the use of variables and global symbol
+macros as case keys.
+
+.TP* Example:
+
+.cblk
+  (defvarl red 0)
+  (defvarl green 1)
+  (defvarl blue 2)
+
+  (let ((color blue))
+    (caseql* color
+      (red "hot")
+      ((green blue) "cool")))
+  --> "cool"
+.cble
+
 .coNP Operator/function @ if
 .synb
 .mets (if < cond < t-form <> [ e-form ])