Add an equality checking argument to member
This commit is contained in:
parent
e23b0b85c0
commit
7ad6d23657
|
@ -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)))
|
||||
|
||||
)
|
||||
|
|
|
@ -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?])
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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)
|
||||
{
|
||||
|
|
Loading…
Reference in New Issue
Block a user