Rewrite boot-9 map to be recursive and pure

* module/ice-9/boot-9.scm (map): Rewrite to be recursive and pure
  instead of iterative and effectful.  At best this is faster; at worst
  it is slower.  In any case it resolves continuation-related issues.

* module/srfi/srfi-1.scm (fold): Specialize the two-arg case.
  (map): Rewrite to be recursive.

* test-suite/tests/r5rs_pitfall.test (8.3): Update for new expected map
  behavior.

diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 8bc8e53..7f38c4b 100644 (file)
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -239,49 +239,83 @@ file with the given name already exists, the effect is unspecified."
 
 \f
 
-;;; Boot versions of `map' and `for-each', enough to get the expander
-;;; running.
+;;; {map and for-each}
 ;;;
+
 (define map
   (case-lambda
     ((f l)
+     (if (not (list? l))
+         (scm-error 'wrong-type-arg "map" "Not a list: ~S"
+                    (list l) #f))
      (let map1 ((l l))
-       (if (null? l)
-           '()
-           (cons (f (car l)) (map1 (cdr l))))))
+       (if (pair? l)
+           (cons (f (car l)) (map1 (cdr l)))
+           '())))
+
     ((f l1 l2)
+     (if (not (= (length l1) (length l2)))
+         (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
+                    (list l2) #f))
+
      (let map2 ((l1 l1) (l2 l2))
-       (if (null? l1)
-           '()
+       (if (pair? l1)
            (cons (f (car l1) (car l2))
-                 (map2 (cdr l1) (cdr l2))))))
+                 (map2 (cdr l1) (cdr l2)))
+           '())))
+
     ((f l1 . rest)
-     (let lp ((l1 l1) (rest rest))
-       (if (null? l1)
-           '()
+     (let ((len (length l1)))
+       (let mapn ((rest rest))
+         (or (null? rest)
+             (if (= (length (car rest)) len)
+                 (mapn (cdr rest))
+                 (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
+                            (list (car rest)) #f)))))
+     (let mapn ((l1 l1) (rest rest))
+       (if (pair? l1)
            (cons (apply f (car l1) (map car rest))
-                 (lp (cdr l1) (map cdr rest))))))))
+                 (mapn (cdr l1) (map cdr rest)))
+           '())))))
+
+(define map-in-order map)
 
 (define for-each
   (case-lambda
     ((f l)
+     (if (not (list? l))
+         (scm-error 'wrong-type-arg "for-each" "Not a list: ~S" (list l) #f))
      (let for-each1 ((l l))
-       (if (pair? l)
+       (if (not (null? l))
            (begin
              (f (car l))
              (for-each1 (cdr l))))))
+
     ((f l1 l2)
+     (if (not (= (length l1) (length l2)))
+         (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
+                    (list l2) #f))
      (let for-each2 ((l1 l1) (l2 l2))
-       (if (pair? l1)
+       (if (not (null? l1))
            (begin
              (f (car l1) (car l2))
              (for-each2 (cdr l1) (cdr l2))))))
+
     ((f l1 . rest)
-     (let lp ((l1 l1) (rest rest))
+     (let ((len (length l1)))
+       (let for-eachn ((rest rest))
+         (or (null? rest)
+             (if (= (length (car rest)) len)
+                 (for-eachn (cdr rest))
+                 (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
+                            (list (car rest)) #f)))))
+
+     (let for-eachn ((l1 l1) (rest rest))
        (if (pair? l1)
            (begin
              (apply f (car l1) (map car rest))
-             (lp (cdr l1) (map cdr rest))))))))
+             (for-eachn (cdr l1) (map cdr rest))))))))
+
 
 ;; Temporary definition used in the include-from-path expansion;
 ;; replaced later.
@@ -831,83 +865,6 @@ for key @var{k}, then invoke @var{thunk}."
 
 \f
 
-;;; The real versions of `map' and `for-each', with cycle detection, and
-;;; that use reverse! instead of recursion in the case of `map'.
-;;;
-(define map
-  (case-lambda
-    ((f l)
-     (unless (list? l)
-       (scm-error 'wrong-type-arg "map" "Not a list: ~S"
-                  (list l) #f))
-     (let map1 ((l l) (out '()))
-       (if (pair? l)
-           (map1 (cdr l) (cons (f (car l)) out))
-           (reverse! out))))
-    
-    ((f l1 l2)
-     (unless (= (length l1) (length l2))
-       (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
-                  (list l2) #f))
-
-     (let map2 ((l1 l1) (l2 l2) (out '()))
-       (if (pair? l1)
-           (map2 (cdr l1) (cdr l2) (cons (f (car l1) (car l2)) out))
-           (reverse! out))))
-
-    ((f l1 . rest)
-     (let ((len (length l1)))
-       (let mapn ((rest rest))
-         (or (null? rest)
-             (if (= (length (car rest)) len)
-                 (mapn (cdr rest))
-                 (scm-error 'wrong-type-arg "map" "List of wrong length: ~S"
-                            (list (car rest)) #f)))))
-     (let mapn ((l1 l1) (rest rest) (out '()))
-       (if (null? l1)
-           (reverse! out)
-           (mapn (cdr l1) (map cdr rest)
-                 (cons (apply f (car l1) (map car rest)) out)))))))
-
-(define map-in-order map)
-
-(define for-each
-  (case-lambda
-    ((f l)
-     (unless (list? l)
-       (scm-error 'wrong-type-arg "for-each" "Not a list: ~S" (list l) #f))
-     (let for-each1 ((l l))
-       (unless (null? l)
-         (f (car l))
-         (for-each1 (cdr l)))))
-
-    ((f l1 l2)
-     (unless (= (length l1) (length l2))
-       (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
-                  (list l2) #f))
-     (let for-each2 ((l1 l1) (l2 l2))
-       (unless (null? l1)
-         (f (car l1) (car l2))
-         (for-each2 (cdr l1) (cdr l2)))))
-
-    ((f l1 . rest)
-     (let ((len (length l1)))
-       (let for-eachn ((rest rest))
-         (or (null? rest)
-             (if (= (length (car rest)) len)
-                 (for-eachn (cdr rest))
-                 (scm-error 'wrong-type-arg "for-each" "List of wrong length: ~S"
-                            (list (car rest)) #f)))))
-     
-     (let for-eachn ((l1 l1) (rest rest))
-       (if (pair? l1)
-           (begin
-             (apply f (car l1) (map car rest))
-             (for-eachn (cdr l1) (map cdr rest))))))))
-
-
-\f
-
 ;;;
 ;;; Extensible exception printing.
 ;;;

diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 5e859d1..0806e73 100644 (file)
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -454,21 +454,41 @@ a list of those after."
 
 ;;; Fold, unfold & map
 
-(define (fold kons knil list1 . rest)
-  "Apply PROC to the elements of LIST1 ... LISTN to build a result, and return
+(define fold
+  (case-lambda
+    "Apply PROC to the elements of LIST1 ... LISTN to build a result, and return
 that result.  See the manual for details."
-  (check-arg procedure? kons fold)
-  (if (null? rest)
-      (let f ((knil knil) (list1 list1))
-       (if (null? list1)
-           knil
-           (f (kons (car list1) knil) (cdr list1))))
-      (let f ((knil knil) (lists (cons list1 rest)))
-       (if (any null? lists)
-           knil
-           (let ((cars (map car lists))
-                 (cdrs (map cdr lists)))
-             (f (apply kons (append! cars (list knil))) cdrs))))))
+    ((kons knil list1)
+     (check-arg procedure? kons fold)
+     (check-arg list? list1 fold)
+     (let fold1 ((knil knil) (list1 list1))
+       (if (pair? list1)
+           (fold1 (kons (car list1) knil) (cdr list1))
+           knil)))
+    ((kons knil list1 list2)
+     (check-arg procedure? kons fold)
+     (let* ((len1 (length+ list1))
+            (len2 (length+ list2))
+            (len (if (and len1 len2)
+                     (min len1 len2)
+                     (or len1 len2))))
+       (unless len
+         (scm-error 'wrong-type-arg "fold"
+                    "Args do not contain a proper (finite) list: ~S"
+                    (list (list list1 list2)) #f))
+       (let fold2 ((knil knil) (list1 list1) (list2 list2) (len len))
+         (if (zero? len)
+             knil
+             (fold2 (kons (car list1) (car list2) knil)
+                    (cdr list1) (cdr list2) (1- len))))))
+    ((kons knil list1 . rest)
+     (check-arg procedure? kons fold)
+     (let foldn ((knil knil) (lists (cons list1 rest)))
+       (if (any null? lists)
+           knil
+           (let ((cars (map car lists))
+                 (cdrs (map cdr lists)))
+             (foldn (apply kons (append! cars (list knil))) cdrs)))))))
 
 (define (fold-right kons knil clist1 . rest)
   (check-arg procedure? kons fold-right)
@@ -567,10 +587,10 @@ has just one element then that's the return value."
     ((f l)
      (check-arg procedure? f map)
      (check-arg list? l map)
-     (let map1 ((in l) (out '()))
-       (if (pair? in)
-           (map1 (cdr in) (cons (f (car in)) out))
-           (reverse! out))))
+     (let map1 ((l l))
+       (if (pair? l)
+           (cons (f (car l)) (map1 (cdr l)))
+           '())))
     
     ((f l1 l2)
      (check-arg procedure? f map)
@@ -583,11 +603,11 @@ has just one element then that's the return value."
          (scm-error 'wrong-type-arg "map"
                     "Args do not contain a proper (finite) list: ~S"
                     (list (list l1 l2)) #f))
-       (let map2 ((l1 l1) (l2 l2) (out '()) (len len))
+       (let map2 ((l1 l1) (l2 l2) (len len))
          (if (zero? len)
-             (reverse! out)
-             (map2 (cdr l1) (cdr l2)
-                   (cons (f (car l1) (car l2)) out) (1- len))))))
+             '()
+             (cons (f (car l1) (car l2))
+                   (map2 (cdr l1) (cdr l2) (1- len)))))))
 
     ((f l1 . rest)
      (check-arg procedure? f map)
@@ -602,11 +622,11 @@ has just one element then that's the return value."
            (scm-error 'wrong-type-arg "map"
                       "Args do not contain a proper (finite) list: ~S"
                       (list (cons l1 rest)) #f))
-       (let mapn ((l1 l1) (rest rest) (len len) (out '()))
+       (let mapn ((l1 l1) (rest rest) (len len))
          (if (zero? len)
-             (reverse! out)
-             (mapn (cdr l1) (map cdr rest) (1- len)
-                   (cons (apply f (car l1) (map car rest)) out))))))))
+             '()
+             (cons (apply f (car l1) (map car rest))
+                   (mapn (cdr l1) (map cdr rest) (1- len)))))))))
 
 (define map-in-order map)
 

diff --git a/test-suite/tests/r5rs_pitfall.test b/test-suite/tests/r5rs_pitfall.test
index 0bab38c..1d9fcf7 100644 (file)
--- a/test-suite/tests/r5rs_pitfall.test
+++ b/test-suite/tests/r5rs_pitfall.test
@@ -1,5 +1,5 @@
 ;;;; r5rs_pitfall.test --- tests some pitfalls in R5RS     -*- scheme -*-
-;;;; Copyright (C) 2003, 2004, 2006 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2004, 2006, 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
@@ -292,7 +292,7 @@
 ;;Not really an error to fail this (Matthias Radestock)
 ;;If this returns (0 1 0), your map isn't call/cc safe, but is probably
 ;;tail-recursive.  If its (0 0 0), the opposite is true.
-(should-be 8.3 '(0 1 0)
+(should-be 8.3 '(0 0 0)
   (let ()
     (define executed-k #f)
     (define cont #f)