New keepq, keepql and keepqual functions.

* eval.c (eval_init): Register keepq, keepql and keepqual
intrinsic functions.

* lib.c (keepq, keepql, keepqual): New functions.

* lib.h (keepq, keepql, keepqual): Declared.

4 files changed, 110 insertions, 0 deletions

diff --git a/eval.c b/eval.c
index 3f4f606b..a1809aca 100644
--- a/eval.c
+++ b/eval.c
@@ -5025,6 +5025,9 @@ void eval_init(void)
   reg_fun(intern(lit("remql"), user_package), func_n2(remql));
   reg_fun(intern(lit("remqual"), user_package), func_n2(remqual));
   reg_fun(intern(lit("remove-if"), user_package), func_n3o(remove_if, 2));
+  reg_fun(intern(lit("keepq"), user_package), func_n3o(keepq, 2));
+  reg_fun(intern(lit("keepql"), user_package), func_n3o(keepql, 2));
+  reg_fun(intern(lit("keepqual"), user_package), func_n3o(keepqual, 2));
   reg_fun(intern(lit("keep-if"), user_package), func_n3o(keep_if, 2));
   reg_fun(intern(lit("remq*"), user_package), func_n2(remq_lazy));
   reg_fun(intern(lit("remql*"), user_package), func_n2(remql_lazy));
diff --git a/lib.c b/lib.c
index 1ed27766..0134d477 100644
--- a/lib.c
+++ b/lib.c
@@ -1554,6 +1554,67 @@ val remove_if(val pred, val list_orig, val key)
   return make_like(out, list_orig);
 }
 
+val keepq(val obj, val list_orig, val key)
+{
+  list_collect_decl (out, ptail);
+  val list = tolist(list_orig);
+  val lastmatch = cons(nil, list);
+
+  key = default_arg(key, identity_f);
+
+  gc_hint(list);
+
+  for (; list; list = cdr(list)) {
+    if (funcall1(key, car(list)) != obj) {
+      ptail = list_collect_nconc(ptail, ldiff(cdr(lastmatch), list));
+      lastmatch = list;
+    }
+  }
+  ptail = list_collect_nconc(ptail, cdr(lastmatch));
+  return make_like(out, list_orig);
+}
+
+val keepql(val obj, val list_orig, val key)
+{
+  list_collect_decl (out, ptail);
+  val list = tolist(list_orig);
+  val lastmatch = cons(nil, list);
+
+  key = default_arg(key, identity_f);
+
+  gc_hint(list);
+
+  for (; list; list = cdr(list)) {
+    if (!eql(funcall1(key, car(list)), obj)) {
+      ptail = list_collect_nconc(ptail, ldiff(cdr(lastmatch), list));
+      ptail = list_collect_nconc(ptail, ldiff(cdr(lastmatch), list));
+      lastmatch = list;
+    }
+  }
+  ptail = list_collect_nconc(ptail, cdr(lastmatch));
+  return make_like(out, list_orig);
+}
+
+val keepqual(val obj, val list_orig, val key)
+{
+  list_collect_decl (out, ptail);
+  val list = tolist(list_orig);
+  val lastmatch = cons(nil, list);
+
+  key = default_arg(key, identity_f);
+
+  gc_hint(list);
+
+  for (; list; list = cdr(list)) {
+    if (!equal(funcall1(key, car(list)), obj)) {
+      ptail = list_collect_nconc(ptail, ldiff(cdr(lastmatch), list));
+      lastmatch = list;
+    }
+  }
+  ptail = list_collect_nconc(ptail, cdr(lastmatch));
+  return make_like(out, list_orig);
+}
+
 val keep_if(val pred, val list_orig, val key)
 {
   list_collect_decl (out, ptail);
diff --git a/lib.h b/lib.h
index 0785639f..f17def75 100644
--- a/lib.h
+++ b/lib.h
@@ -554,6 +554,9 @@ val remq(val obj, val list);
 val remql(val obj, val list);
 val remqual(val obj, val list);
 val remove_if(val pred, val list, val key);
+val keepq(val obj, val list_orig, val key);
+val keepql(val obj, val list_orig, val key);
+val keepqual(val obj, val list_orig, val key);
 val keep_if(val pred, val list, val key);
 val remq_lazy(val obj, val list);
 val remql_lazy(val obj, val list);
diff --git a/txr.1 b/txr.1
index 96b15fe8..72607129 100644
--- a/txr.1
+++ b/txr.1
@@ -22497,6 +22497,49 @@ does not have to be deleted, in order to instantiate the first lazy value.
   [(remql* 13 (range 1)) 0..100]
 .cble
 
+.coNP Functions @, keepq @ keepql and @ keepqual
+.synb
+.mets (keepq < object < list <> [ key-function ])
+.mets (keepql < object < list <> [ key-function ])
+.mets (keepqual < object < list <> [ key-function ])
+.syne
+.desc
+The
+.codn keepq ,
+.code keepql
+and
+.code keepqual
+functions produce a new list based on
+.metn list ,
+removing the items whose keys are not
+.codn eq ,
+.code eql
+or
+.code equal
+to
+.metn object .
+
+The input
+.meta list
+is unmodified, but the returned list may share substructure
+with it. If no items are removed, it is possible that the return value
+is
+.meta list
+itself.
+
+The optional
+.meta key-function
+is applied to each element from the
+.meta list
+to convert it to a key which is compared to
+.metn object .
+If
+.meta key-function
+is omitted, then each element itself of
+.meta list
+is compared to
+.metn object .
+
 .coNP Functions @, remove-if @, keep-if @ remove-if* and @ keep-if*
 .synb
 .mets (remove-if < predicate-function < list <> [ key-function ])