From 7ad6d236575f4ab69f2b68242d5f72eb639822ee Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Sun, 9 Jun 2013 21:18:56 -0400
Subject: [PATCH] Add an equality checking argument to `member`

---
 collects/racket/private/list.rkt           | 18 ++++++-
 collects/scribblings/reference/pairs.scrbl |  7 ++-
 collects/tests/racket/basic.rktl           | 14 +++++-
 src/racket/src/list.c                      | 55 +++++++++++++++++++++-
 4 files changed, 88 insertions(+), 6 deletions(-)

diff --git a/collects/racket/private/list.rkt b/collects/racket/private/list.rkt
index 0985f3fc2b..3cbadd313e 100644
--- a/collects/racket/private/list.rkt
+++ b/collects/racket/private/list.rkt
@@ -427,9 +427,25 @@
                         [(eq? v (car ls)) ls]
                         [else (loop (cdr ls))])))])
               id))
+          ;; Create the `member` function that takes an extra argument
+          ;; Uses `mk` to construct the body
+          (define-syntax-rule (mk-member id)
+            (let* ([default (mk member equal?)]
+                   [id (case-lambda
+                        ([v orig-l] (default v orig-l))
+                        ([v orig-l eq?]
+                         (unless (and (procedure? eq?)
+                                      (procedure-arity-includes? eq? 2))
+                           (raise-argument-error
+                            'member
+                            "(procedure-arity-includes/c 2)"
+                            eq?))
+                         ((mk member eq?) v orig-l)))])
+              id))
           (values (mk memq eq?)
                   (mk memv eqv?)
-                  (mk member equal?)))
+                  ;; Note that this uses `mk-member`
+                  (mk-member member)))
         (values memq memv member)))
 
   )
diff --git a/collects/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl
index 9df10f9212..68637773d5 100644
--- a/collects/scribblings/reference/pairs.scrbl
+++ b/collects/scribblings/reference/pairs.scrbl
@@ -563,7 +563,8 @@ effectively shuffles the list.}
 @; ----------------------------------------
 @section{List Searching}
 
-@defproc[(member [v any/c] [lst list?])
+@defproc[(member [v any/c] [lst list?]
+                 [is-equal? (any/c any/c -> any/c) equal?])
          (or/c list? #f)]{
 
 Locates the first element of @racket[lst] that is @racket[equal?] to
@@ -573,7 +574,9 @@ starting with that element is returned.  Otherwise, the result is
 
 @mz-examples[
   (member 2 (list 1 2 3 4))
-  (member 9 (list 1 2 3 4))]}
+  (member 9 (list 1 2 3 4))
+  (member #'x (list #'x #'y) free-identifier=?)
+  (member #'a (list #'x #'y) free-identifier=?)]}
 
 
 @defproc[(memv [v any/c] [lst list?])
diff --git a/collects/tests/racket/basic.rktl b/collects/tests/racket/basic.rktl
index 877099314a..128f9176c6 100644
--- a/collects/tests/racket/basic.rktl
+++ b/collects/tests/racket/basic.rktl
@@ -264,7 +264,9 @@
   (test '(b . c) memq 'b '(a b . c))
   (test '#f memq 'a '(b c d))
 
-  (arity-test memq 2 2)
+  (if (eq? memq-name 'member)
+      (arity-test memq 2 3)
+      (arity-test memq 2 2))
   (err/rt-test (memq 'a 1) exn:application:mismatch?)
   (err/rt-test (memq 'a '(1 . 2)) exn:application:mismatch?))
 
@@ -285,6 +287,16 @@
 
 (test '((1 2)) member '(1 2) '(1 2 (1 2)))
 
+;; Additional tests for member with equality check argument
+(let ([stxs (list #'a #'b #'c)])
+  (test stxs member #'a stxs free-identifier=?)
+  (test (cdr stxs) member #'b stxs free-identifier=?)
+  (test #f member #'z stxs free-identifier=?))
+(test '(2 1 2) member 2 '(1 2 1 2) =)
+(test #f member 2 '(3 4 5 6) =)
+(test '(#"b" #"c") member #"b" '(#"a" #"b" #"c") bytes=?)
+(test #f member #"z" '(#"a" #"b" #"c") bytes=?)
+
 (define (test-ass assq assq-name)
   (define e '((a 1) (b 2) (c 3)))
   (test '(a 1) assq 'a e)
diff --git a/src/racket/src/list.c b/src/racket/src/list.c
index ef38de58c2..90e5129784 100644
--- a/src/racket/src/list.c
+++ b/src/racket/src/list.c
@@ -310,7 +310,7 @@ scheme_init_list (Scheme_Env *env)
   scheme_add_global_constant ("member",
 			      scheme_make_immed_prim(member,
 						     "member",
-						     2, 2),
+						     2, 3),
 			      env);
   scheme_add_global_constant ("assq",
 			      scheme_make_immed_prim(assq,
@@ -1487,7 +1487,58 @@ name (int argc, Scheme_Object *argv[]) \
 
 GEN_MEM(memv, memv, scheme_eqv)
 GEN_MEM(memq, memq, SAME_OBJ)
-GEN_MEM(member, member, scheme_equal)
+
+static Scheme_Object *member(int argc, Scheme_Object *argv[])
+{
+  Scheme_Object *list, *turtle;
+  Scheme_Object *comp = NULL;
+  Scheme_Object *a[2];
+  list = turtle = argv[1];
+
+  if (argc > 2) {
+    if (SCHEME_PROCP(argv[2]) && scheme_check_proc_arity("member", 2, 2, 3, argv)) {
+      comp = argv[2];
+    } else {
+      scheme_wrong_contract("member", "(procedure-arity-includes/c 2)", 2, argc, argv);
+    }
+  }
+
+  while (SCHEME_PAIRP(list)) {
+    if (comp) {
+      a[0] = argv[0];
+      a[1] = SCHEME_CAR(list);
+      if (SCHEME_TRUEP(scheme_apply(comp, 2, a))) {
+        return list;
+      }
+    } else {
+      if (scheme_equal(argv[0], SCHEME_CAR(list))) {
+        return list;
+      }
+    }
+    list = SCHEME_CDR(list);
+    if (SCHEME_PAIRP(list)) {
+      if (comp) {
+        a[0] = argv[0];
+        a[1] = SCHEME_CAR(list);
+        if (SCHEME_TRUEP(scheme_apply(comp, 2, a))) {
+          return list;
+        }
+      } else {
+        if (scheme_equal(argv[0], SCHEME_CAR(list))) {
+          return list;
+        }
+      }
+      if (SAME_OBJ(list, turtle)) break;
+      list = SCHEME_CDR (list);
+      turtle = SCHEME_CDR (turtle);
+      SCHEME_USE_FUEL(1);
+    }
+  }
+  if (!SCHEME_NULLP(list)) {
+    mem_past_end("member", argv[0], argv[1]);
+  }
+  return (scheme_false);
+}
 
 static void ass_non_pair(const char *name, Scheme_Object *np, Scheme_Object *s_arg, Scheme_Object *arg)
 {