add an optional argument to `assoc'

and implement `assoc', `assq', and `assv' in Racket

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)
+  (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))
-    (let loop ([l list])
+         (assoc-loop 'assf #f l (lambda (_ a) (f a)))))))
-      (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)))])))
 
   ;; fold : ((A B -> B) B (listof A) -> B)
   ;; fold : ((A1 ... An B -> B) B (listof A1) ... (listof An) -> 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

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)

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

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