From 41447008f2eff57119a5f9414ab1a74c4d3183a1 Mon Sep 17 00:00:00 2001
From: Kaz Kylheku <kaz@kylheku.com>
Date: Sat, 22 Feb 2020 00:53:12 -0800
Subject: New functions: meq, meql and mequal.

* eval.c (eval_init): Register meq, meql an mequal intrinsics.

* lib.c (meq, meql, mequal): New functions.

* lib.h (meq, meql, mequal): Declared.

* txr.1: Documented.
---
 eval.c |  3 +++
 lib.c  | 27 +++++++++++++++++++++++++++
 lib.h  |  3 +++
 txr.1  | 36 ++++++++++++++++++++++++++++++++++++
 4 files changed, 69 insertions(+)

diff --git a/eval.c b/eval.c
index c43dcb32..6cf58fcb 100644
--- a/eval.c
+++ b/eval.c
@@ -6554,6 +6554,9 @@ void eval_init(void)
   reg_fun(eq_s, eq_f);
   reg_fun(eql_s, eql_f);
   reg_fun(equal_s, equal_f);
+  reg_fun(intern(lit("meq"), user_package), func_n1v(meq));
+  reg_fun(intern(lit("meql"), user_package), func_n1v(meql));
+  reg_fun(intern(lit("mequal"), user_package), func_n1v(mequal));
   reg_fun(intern(lit("neq"), user_package), func_n2(neq));
   reg_fun(intern(lit("neql"), user_package), func_n2(neql));
   reg_fun(intern(lit("nequal"), user_package), func_n2(nequal));
diff --git a/lib.c b/lib.c
index ec17d81b..011da356 100644
--- a/lib.c
+++ b/lib.c
@@ -2898,6 +2898,33 @@ val equal(val left, val right)
   return nil;
 }
 
+val meq(val item, varg args)
+{
+  cnum index = 0;
+  while (args_more(args, index))
+    if (eq(item, args_get(args, &index)))
+      return t;
+  return nil;
+}
+
+val meql(val item, varg args)
+{
+  cnum index = 0;
+  while (args_more(args, index))
+    if (eql(item, args_get(args, &index)))
+      return t;
+  return nil;
+}
+
+val mequal(val item, varg args)
+{
+  cnum index = 0;
+  while (args_more(args, index))
+    if (equal(item, args_get(args, &index)))
+      return t;
+  return nil;
+}
+
 alloc_bytes_t malloc_bytes;
 
 static void oom(void)
diff --git a/lib.h b/lib.h
index d54ac735..76e2f143 100644
--- a/lib.h
+++ b/lib.h
@@ -658,6 +658,9 @@ val none_satisfy(val list, val pred, val key);
 val multi(val func, struct args *lists);
 val eql(val left, val right);
 val equal(val left, val right);
+val meq(val item, varg args);
+val meql(val item, varg args);
+val mequal(val item, varg args);
 mem_t *chk_malloc(size_t size);
 mem_t *chk_malloc_gc_more(size_t size);
 mem_t *chk_calloc(size_t n, size_t size);
diff --git a/txr.1 b/txr.1
index d35989dd..ea0f07cf 100644
--- a/txr.1
+++ b/txr.1
@@ -18152,6 +18152,42 @@ and between
 and
 .codn nequal .
 
+.coNP Functions @, meq @ meql and @ mequal
+.synb
+.mets (meq < left-obj << right-obj *)
+.mets (meql < left-obj << right-obj *)
+.mets (mequal < left-obj << right-obj *)
+.syne
+.desc
+The functions
+.codn meq ,
+.code meql
+and
+.code mequal
+("member equal" or "multi-equal")
+provide a particular kind of a generalization of the binary
+equality functions
+.codn eq ,
+.code eql
+and
+.code equal
+to multiple arguments.
+
+The
+.meta left-obj
+value is compared to each
+.meta right-obj
+value using the corresponding binary equality function.
+If a match occurs, then
+.code t
+is returned, otherwise
+.codn nil .
+
+The traversal of the
+.meta right-obj
+argument values proceeds from left to right, and stops
+when a match is found.
+
 .coNP Function @ less
 .synb
 .mets (less < left-obj << right-obj )
-- 
cgit v1.2.3