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

let-bind assq, etc for correct object-name

Browse Source
This commit is contained in:
Ryan Culpepper 2011-04-24 14:27:36 -06:00
parent 4aabaeb7af
commit fab332a409
1 changed files with 20 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -164,21 +164,26 @@
(bad-item who a orig-l)))] (bad-item who a orig-l)))]
[(null? l) #f] [(null? l) #f]
[else (bad-list who orig-l)]))) [else (bad-list who orig-l)])))
(values (let ([assq
(lambda (x l) (lambda (x l)
(assoc-loop 'assq x l eq?)) (assoc-loop 'assq x l eq?))]
(lambda (x l) [assv
(assoc-loop 'assv x l eqv?)) (lambda (x l)
(case-lambda (assoc-loop 'assv x l eqv?))]
[(x l) (assoc-loop 'assoc x l equal?)] [assoc
[(x l is-equal?) (case-lambda
(unless (and (procedure? is-equal?) (procedure-arity-includes? is-equal? 2)) [(x l) (assoc-loop 'assoc x l equal?)]
(raise-type-error 'assoc "procedure (arity 2)" is-equal?)) [(x l is-equal?)
(assoc-loop 'assoc x l is-equal?)]) (unless (and (procedure? is-equal?)
(lambda (f l) (procedure-arity-includes? is-equal? 2))
(unless (and (procedure? f) (procedure-arity-includes? f 1)) (raise-type-error 'assoc "procedure (arity 2)" is-equal?))
(raise-type-error 'assf "procedure (arity 1)" f)) (assoc-loop 'assoc x l is-equal?)])]
(assoc-loop 'assf #f l (lambda (_ a) (f a))))))) [assf
(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))))])
(values assq assv assoc assf))))
;; fold : ((A B -> B) B (listof A) -> B) ;; fold : ((A B -> B) B (listof A) -> B)
;; fold : ((A1 ... An B -> B) B (listof A1) ... (listof An) -> B) ;; fold : ((A1 ... An B -> B) B (listof A1) ... (listof An) -> B)