suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

add an optional argument to `assoc'

Browse Source 
and implement `assoc', `assq', and `assv' in Racket
This commit is contained in:
Matthew Flatt 2011-04-23 17:17:21 -06:00
parent 3dffd5fbe6
commit 2f8006aa6b
5 changed files with 73 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

80
collects/racket/private/list.rkt
View File

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

3
collects/racket/private/pre-base.rkt
View File

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

2
collects/scheme/mzscheme.rkt
View File

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

9
collects/scribblings/reference/pairs.scrbl
View File

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

2
collects/tests/racket/basic.rktl
View File

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