Simplify boot-9 and srfi-1 map

[bpt/guile.git] / module / srfi / srfi-1.scm

diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 765bd50..919d512 100644 (file)
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -1,6 +1,6 @@
 ;;; srfi-1.scm --- List Library
 
-;;     Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
+;;     Copyright (C) 2001, 2002, 2003, 2004, 2005, 2006, 2009, 2010, 2011, 2014 Free Software Foundation, Inc.
 ;;
 ;; This library is free software; you can redistribute it and/or
 ;; modify it under the terms of the GNU Lesser General Public
@@ -240,11 +240,9 @@ higher-order procedures."
   (scm-error 'wrong-type-arg (symbol->string caller)
              "Wrong type argument: ~S" (list arg) '()))
 
-(define-syntax check-arg
-  (syntax-rules ()
-    ((_ pred arg caller)
-     (if (not (pred arg))
-         (wrong-type-arg 'caller arg)))))
+(define-syntax-rule (check-arg pred arg caller)
+  (if (not (pred arg))
+      (wrong-type-arg 'caller arg)))
 
 (define (out-of-range proc arg)
   (scm-error 'out-of-range proc
@@ -568,20 +566,11 @@ has just one element then that's the return value."
   (case-lambda
     ((f l)
      (check-arg procedure? f map)
-     (let map1 ((hare l) (tortoise l) (move? #f) (out '()))
-       (if (pair? hare)
-           (if move?
-               (if (eq? tortoise hare)
-                   (scm-error 'wrong-type-arg "map" "Circular list: ~S"
-                              (list l) #f)
-                   (map1 (cdr hare) (cdr tortoise) #f
-                       (cons (f (car hare)) out)))
-               (map1 (cdr hare) tortoise #t
-                     (cons (f (car hare)) out)))
-           (if (null? hare)
-               (reverse! out)
-               (scm-error 'wrong-type-arg "map" "Not a list: ~S"
-                          (list l) #f)))))
+     (check-arg list? l map)
+     (let map1 ((in l) (out '()))
+       (if (pair? in)
+           (map1 (cdr in) (cons (f (car in)) out))
+           (reverse! out))))
     
     ((f l1 . rest)
      (check-arg procedure? f map)
@@ -608,23 +597,28 @@ has just one element then that's the return value."
   (case-lambda
     ((f l)
      (check-arg procedure? f for-each)
-     (let for-each1 ((hare l) (tortoise l) (move? #f))
-       (if (pair? hare)
-           (if move?
-               (if (eq? tortoise hare)
-                   (scm-error 'wrong-type-arg "for-each" "Circular list: ~S"
-                              (list l) #f)
-                   (begin
-                     (f (car hare))
-                     (for-each1 (cdr hare) (cdr tortoise) #f)))
-               (begin
-                 (f (car hare))
-                 (for-each1 (cdr hare) tortoise #t)))
-           
-           (if (not (null? hare))
-               (scm-error 'wrong-type-arg "for-each" "Not a list: ~S"
-                          (list l) #f)))))
-    
+     (check-arg list? l for-each)
+     (let for-each1 ((l l))
+       (unless (null? l)
+         (f (car l))
+         (for-each1 (cdr l)))))
+
+    ((f l1 l2)
+     (check-arg procedure? f for-each)
+     (let* ((len1 (length+ l1))
+            (len2 (length+ l2))
+            (len (if (and len1 len2)
+                     (min len1 len2)
+                     (or len1 len2))))
+       (unless len
+         (scm-error 'wrong-type-arg "for-each"
+                    "Args do not contain a proper (finite) list: ~S"
+                    (list (list l1 l2)) #f))
+       (let for-each2 ((l1 l1) (l2 l2) (len len))
+         (unless (zero? len)
+           (f (car l1) (car l2))
+           (for-each2 (cdr l1) (cdr l2) (1- len))))))
+
     ((f l1 . rest)
      (check-arg procedure? f for-each)
      (let ((len (fold (lambda (ls len)
@@ -654,7 +648,7 @@ has just one element then that's the return value."
 (define map! map)
 
 (define (filter-map proc list1 . rest)
-  "Apply PROC to to the elements of LIST1... and return a list of the
+  "Apply PROC to the elements of LIST1... and return a list of the
 results as per SRFI-1 `map', except that any #f results are omitted from
 the list returned."
   (check-arg procedure? proc filter-map)