From 2f8006aa6b1fc9e406936c1751b493cbb2ddfbd4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 23 Apr 2011 17:17:21 -0600 Subject: [PATCH] add an optional argument to `assoc' and implement `assoc', `assq', and `assv' in Racket --- collects/racket/private/list.rkt | 80 +++++++++++++++++----- collects/racket/private/pre-base.rkt | 3 +- collects/scheme/mzscheme.rkt | 2 + collects/scribblings/reference/pairs.scrbl | 9 ++- collects/tests/racket/basic.rktl | 2 +- 5 files changed, 73 insertions(+), 23 deletions(-) diff --git a/collects/racket/private/list.rkt b/collects/racket/private/list.rkt index fd974a6b88..2e160cd36c 100644 --- a/collects/racket/private/list.rkt +++ b/collects/racket/private/list.rkt @@ -15,6 +15,10 @@ assf findf + assq + assv + assoc + filter sort @@ -26,7 +30,8 @@ compose) (#%require (rename "sort.rkt" raw-sort sort) - (for-syntax "stxcase-scheme.rkt")) + (for-syntax "stxcase-scheme.rkt") + (only '#%unsafe unsafe-car unsafe-cdr)) (provide sort) (define (sort lst less? #:key [getkey #f] #:cache-keys? [cache-keys? #f]) @@ -119,24 +124,61 @@ a (loop (cdr l))))]))) - (define (assf f list) - (unless (and (procedure? f) (procedure-arity-includes? f 1)) - (raise-type-error 'assf "procedure (arity 1)" f)) - (let loop ([l list]) - (cond - [(null? l) #f] - [(not (pair? l)) - (raise-mismatch-error 'assf - "not a proper list: " - list)] - [else (let ([a (car l)]) - (if (pair? a) - (if (f (car a)) - a - (loop (cdr l))) - (raise-mismatch-error 'assf - "found a non-pair in the list: " - a)))]))) + (define (bad-list who orig-l) + (raise-mismatch-error who + "not a propert list: " + orig-l)) + (define (bad-item who a orig-l) + (raise-mismatch-error who + "non-pair found in list: " + a + " in " + orig-l)) + + (define-values (assq assv assoc assf) + (let () + (define-syntax-rule (assoc-loop who x orig-l is-equal?) + (let loop ([l orig-l][t orig-l]) + (cond + [(pair? l) + (let ([a (unsafe-car l)]) + (if (pair? a) + (if (is-equal? x (unsafe-car a)) + a + (let ([l (unsafe-cdr l)]) + (cond + [(eq? l t) (bad-list who orig-l)] + [(pair? l) + (let ([a (unsafe-car l)]) + (if (pair? a) + (if (is-equal? x (unsafe-car a)) + a + (let ([t (unsafe-cdr t)] + [l (unsafe-cdr l)]) + (if (eq? l t) + (bad-list who orig-l) + (loop l t)))) + (bad-item who a orig-l)))] + [(null? l) #f] + [else (bad-list who orig-l)]))) + (bad-item who a orig-l)))] + [(null? l) #f] + [else (bad-list who orig-l)]))) + (values + (lambda (x l) + (assoc-loop 'assq x l eq?)) + (lambda (x l) + (assoc-loop 'assv x l eqv?)) + (case-lambda + [(x l) (assoc-loop 'assoc x l equal?)] + [(x l is-equal?) + (unless (and (procedure? is-equal?) (procedure-arity-includes? is-equal? 2)) + (raise-type-error 'assoc "procedure (arity 2)" is-equal?)) + (assoc-loop 'assoc x l is-equal?)]) + (lambda (f l) + (unless (and (procedure? f) (procedure-arity-includes? f 1)) + (raise-type-error 'assf "procedure (arity 1)" f)) + (assoc-loop 'assf #f l (lambda (_ a) (f a))))))) ;; fold : ((A B -> B) B (listof A) -> B) ;; fold : ((A1 ... An B -> B) B (listof A1) ... (listof An) -> B) diff --git a/collects/racket/private/pre-base.rkt b/collects/racket/private/pre-base.rkt index 1704820d68..050bd886a7 100644 --- a/collects/racket/private/pre-base.rkt +++ b/collects/racket/private/pre-base.rkt @@ -133,7 +133,8 @@ (all-from-except '#%kernel lambda λ #%app #%module-begin apply prop:procedure procedure-arity procedure-reduce-arity raise-arity-error procedure->method procedure-rename - chaperone-procedure impersonate-procedure) + chaperone-procedure impersonate-procedure + assq assv assoc) (all-from "reqprov.rkt") (all-from-except "for.rkt" define-in-vector-like diff --git a/collects/scheme/mzscheme.rkt b/collects/scheme/mzscheme.rkt index 43e5bc9f4a..c34b97add4 100644 --- a/collects/scheme/mzscheme.rkt +++ b/collects/scheme/mzscheme.rkt @@ -18,6 +18,7 @@ racket/private/kernstruct racket/private/promise (only racket/private/cond old-cond) + (only racket/private/list assq assv assoc) ; shadows #%kernel bindings racket/tcp racket/udp '#%builtin) ; so it's attached @@ -90,6 +91,7 @@ make-namespace #%top-interaction map for-each andmap ormap + assq assv assoc (rename datum #%datum) (rename mzscheme-in-stx-module-begin #%module-begin) (rename #%module-begin #%plain-module-begin) diff --git a/collects/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl index 28394090a8..de6a396da0 100644 --- a/collects/scribblings/reference/pairs.scrbl +++ b/collects/scribblings/reference/pairs.scrbl @@ -585,16 +585,21 @@ Like @scheme[memf], but returns the element or @scheme[#f] ]} -@defproc[(assoc [v any/c] [lst (listof pair?)]) +@defproc[(assoc [v any/c] + [lst (listof pair?)] + [is-equal? (any/c any/c -> any/c) equal?]) (or/c pair? #f)]{ Locates the first element of @scheme[lst] whose @scheme[car] is - @scheme[equal?] to @scheme[v]. If such an element exists, the pair + equal to @scheme[v] according to @scheme[is-equal?]. If such an element exists, the pair (i.e., an element of @scheme[lst]) is returned. Otherwise, the result is @scheme[#f]. @mz-examples[ (assoc 3 (list (list 1 2) (list 3 4) (list 5 6))) (assoc 9 (list (list 1 2) (list 3 4) (list 5 6))) +(assoc 3.5 + (list (list 1 2) (list 3 4) (list 5 6)) + (lambda (a b) (< (abs (- a b)) 1))) ]} diff --git a/collects/tests/racket/basic.rktl b/collects/tests/racket/basic.rktl index fc94c7c8c4..eb42faff82 100644 --- a/collects/tests/racket/basic.rktl +++ b/collects/tests/racket/basic.rktl @@ -278,7 +278,7 @@ (test #f assq 'd e) (test '(a 1) assq 'a '((x 0) (a 1) b 2)) (test '(a 1) assq 'a '((x 0) (a 1) . 0)) - (arity-test assq 2 2) + (arity-test assq 2 (if (eq? assq-name 'assoc) 3 2)) (err/rt-test (assq 1 1) exn:application:mismatch?) (err/rt-test (assq 1 '(1 2)) exn:application:mismatch?)