Add an equality checking argument to member

This commit is contained in:
Asumu Takikawa 2013-06-09 21:18:56 -04:00
parent e23b0b85c0
commit 7ad6d23657
4 changed files with 88 additions and 6 deletions

View File

@ -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)))
)

View File

@ -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?])

View File

@ -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)

View File

@ -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)
{