* Improved some more code

* Added `findf'

svn: r3192

collects/mzlib/list.ss

@@ -32,6 +32,7 @@
 
            assf
            memf
+           findf
 
            filter
 
@@ -250,31 +251,36 @@
                 (error 'foldr "received non-equal length input lists")]
                [else init]))]))
 
-  (define (make-find name whole-list?)
+  (define-syntax (define-finder stx)
-    (lambda (f list)
+    (syntax-case stx ()
-      (unless (and (procedure? f) (procedure-arity-includes? f 1))
+      [(_ name mode)
-        (raise-type-error name "procedure (arity 1)" f))
+       (and (identifier? #'name) (memq (syntax-e #'mode) '(assoc member find)))
-      (let loop ([l list])
+       #`(define (name f list)
-        (cond [(null? l) #f]
+           (unless (and (procedure? f) (procedure-arity-includes? f 1))
-              [(not (pair? l)) 
+             (raise-type-error 'name "procedure (arity 1)" f))
-               (raise (make-exn:fail:contract
+           (let loop ([l list])
-                       (format "~a: second argument must be a (proper) list; given ~e" name list)
+             (cond
-                       (current-continuation-marks)))]
+              [(null? l) #f]
+              [(not (pair? l))
+               (raise
+                (make-exn:fail:contract
+                 (string->immutable-string
+                  (format
+                   "~a: second argument must be a (proper) list; given ~e"
+                   'name list))
+                 (current-continuation-marks)))]
               [else (let ([a (car l)])
-                      (if whole-list?
+                      #,(case (syntax-e #'mode)
-                        (if (f a) l (loop (cdr l)))
+                          [(member) #'(if (f a) l (loop (cdr l)))]
-                        (if (pair? a)
+                          [(find)   #'(if (f a) (car l) (loop (cdr l)))]
-                          (if (f (car a)) a (loop (cdr l)))
+                          [(assoc)  #'(if (pair? a)
-                          (raise-mismatch-error
+                                        (if (f (car a)) a (loop (cdr l)))
-                           name "found a non-pair in the list: " a))))]))))
+                                        (raise-mismatch-error
-
+                                         'name "found a non-pair in the list: "
-  (define assf
+                                         a))]))])))]))
-    (let ([a (make-find 'assf #f)])
+  (define-finder assf  assoc)
-      (lambda (f l) (a f l))))
+  (define-finder memf  member)
-
+  (define-finder findf find)
-  (define memf
-    (let ([a (make-find 'memf #t)])
-      (lambda (f l) (a f l))))
 
   (define (filter f list)
     (unless (and (procedure? f)
@@ -297,28 +303,22 @@
   (define (set-first! x v)
     (unless (pair? x) (raise-type-error 'set-first! "non-empty list" x))
     (set-car! x v))
-  (define (lget name npos)
+  (define-syntax define-lgetter
-    (lambda (x)
+    (syntax-rules ()
-      (let loop ([l x][pos npos])
+      [(_ name npos)
-	(cond
+       (define (name l0)
-	 [(and (= pos 1) (pair? l)) (car l)]
+         (let loop ([l l0] [pos npos])
-	 [(pair? l) (loop (cdr l) (sub1 pos))]
+           (if (pair? l)
-	 [else (raise-type-error
+             (if (eq? pos 1) (car l) (loop (cdr l) (sub1 pos)))
-                name (format "list with ~a or more items" npos) x)]))))
+             (raise-type-error
-
+              'name (format "list with ~a or more items" npos) l0))))]))
-  ;; Gives the function a name:
+  (define-lgetter second  2)
-  (define-syntax (mk-lget stx)
+  (define-lgetter third   3)
-    (syntax-case stx ()
+  (define-lgetter fourth  4)
-      [(_ name pos)
+  (define-lgetter fifth   5)
-       (syntax (let ([g (lget 'name pos)]) (lambda (x) (g x))))]))
+  (define-lgetter sixth   6)
-
+  (define-lgetter seventh 7)
-  (define second  (mk-lget second  2))
+  (define-lgetter eighth  8)
-  (define third   (mk-lget third   3))
-  (define fourth  (mk-lget fourth  4))
-  (define fifth   (mk-lget fifth   5))
-  (define sixth   (mk-lget sixth   6))
-  (define seventh (mk-lget seventh 7))
-  (define eighth  (mk-lget eighth  8))
 
   (define (rest x)
     (unless (pair? x)

collects/tests/mzscheme/function.ss

@@ -50,6 +50,12 @@
 (err/rt-test (filter cons '(1 2 3)))
 (arity-test filter 2 2)
 
+(test '(0 1 2) memf add1 '(0 1 2))
+(test '(2 (c 17)) memf number? '((a 1) (0 x) (1 w) 2 (c 17)))
+(test '("ok" (2 .7) c) memf string? '((a 0) (0 a) (1 w) "ok" (2 .7) c))
+(err/rt-test (memf cons '((1) (2) (3))))
+(err/rt-test (memf string? '((1) (2) (3) . 4)) exn:application:mismatch?)
+
 (err/rt-test (assf add1 '(0 1 2)) exn:application:mismatch?)
 (test '(0 x) assf number? '((a 1) (0 x) (1 w) (2 r) (c 17)))
 (test '("ok" . 10) assf string? '((a 0) (0 a) (1 w) ("ok" . 10) (2 .7) c))