From 20a737a17009582fd3022fb2f67e4b472445bc4f Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Sun, 15 Apr 2012 15:15:23 -0700
Subject: * eval.c (eval_init): New intrinsic functions remq*, remql*,
 remqual*, remove-if*, keep-if*.

* lib.c (rem_lazy_func, rem_lazy_rec): New static functions.
(remq_lazy, remql_lazy, remqual_lazy, remove_if_lazy,
keep_if_lazy): New functions.

* lib.h (remq_lazy, remql_lazy, remqual_lazy, remove_if_lazy,
keep_if_lazy): Declared.

* txr.1: New functions documented.
---
 lib.c | 50 ++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 50 insertions(+)

(limited to 'lib.c')

diff --git a/lib.c b/lib.c
index 704c0bd0..979a4889 100644
--- a/lib.c
+++ b/lib.c
@@ -720,6 +720,56 @@ val keep_if(val pred, val list, val key)
   return out;
 }
 
+static val rem_lazy_rec(val obj, val list, val env, val func);
+
+static val rem_lazy_func(val env, val lcons)
+{
+  cons_bind (pred, list, env);
+  return rplacd(lcons, rem_lazy_rec(pred, list, env, lcons_fun(lcons)));
+}
+
+static val rem_lazy_rec(val pred, val list, val env, val func)
+{
+  while (list && funcall1(pred, car(list)))
+    list = cdr(list);
+  if (!list)
+    return nil;
+  if (!env)
+    func = func_f1(cons(pred, cdr(list)), rem_lazy_func);
+  else
+    rplacd(env, cdr(list));
+  return make_half_lazy_cons(func, car(list));
+}
+
+val remq_lazy(val obj, val list)
+{
+  return rem_lazy_rec(curry_12_1(eq_f, obj), list, nil, nil);
+}
+
+val remql_lazy(val obj, val list)
+{
+  return rem_lazy_rec(curry_12_1(eql_f, obj), list, nil, nil);
+}
+
+val remqual_lazy(val obj, val list)
+{
+  return rem_lazy_rec(curry_12_1(equal_f, obj), list, nil, nil);
+}
+
+val remove_if_lazy(val pred, val list, val key)
+{
+  uses_or2;
+  val pred_key = chain(or2(key, identity_f), pred, nao);
+  return rem_lazy_rec(pred_key, list, nil, nil);
+}
+
+val keep_if_lazy(val pred, val list, val key)
+{
+  uses_or2;
+  val pred_key = chain(or2(key, identity_f), pred, null_f, nao);
+  return rem_lazy_rec(pred_key, list, nil, nil);
+}
+
 val tree_find(val obj, val tree, val testfun)
 {
   uses_or2;
-- 
cgit v1.2.3