SRFI-1: Make `fold-right' tail-recursive.

* module/srfi/srfi-1.scm (fold-right): Make tail-recursive.

* test-suite/tests/srfi-1.test ("fold-right"): New test prefix.

diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index 1e006c7..d6cefcd 100644 (file)
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -419,14 +419,18 @@ that result.  See the manual for details."
 
 (define (fold-right kons knil clist1 . rest)
   (if (null? rest)
-    (let f ((list1 clist1))
-      (if (null? list1)
-       knil
-       (kons (car list1) (f (cdr list1)))))
-    (let f ((lists (cons clist1 rest)))
-      (if (any null? lists)
-       knil
-       (apply kons (append! (map1 car lists) (list (f (map1 cdr lists)))))))))
+      (let loop ((lst    (reverse clist1))
+                 (result knil))
+        (if (null? lst)
+            result
+            (loop (cdr lst)
+                  (kons (car lst) result))))
+      (let loop ((lists  (map1 reverse (cons clist1 rest)))
+                 (result knil))
+        (if (any1 null? lists)
+            result
+            (loop (map1 cdr lists)
+                  (apply kons (append! (map1 car lists) (list result))))))))
 
 (define (pair-fold kons knil clist1 . rest)
   (if (null? rest)

diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test
index 8569a3d..eaad8c9 100644 (file)
--- a/test-suite/tests/srfi-1.test
+++ b/test-suite/tests/srfi-1.test
@@ -1266,6 +1266,28 @@
             (equal? '((1 2) (3 4) (5 6)) lst))))))
 
 ;;
+;; fold-right
+;;
+
+(with-test-prefix "fold-right"
+
+  (pass-if "one list"
+    (equal? (iota 10)
+            (fold-right cons '() (iota 10))))
+
+  (pass-if "two lists"
+    (equal? (zip (iota 10) (map integer->char (iota 10)))
+            (fold-right (lambda (x y z)
+                          (cons (list x y) z))
+                        '()
+                        (iota 10)
+                        (map integer->char (iota 10)))))
+
+  (pass-if "tail-recursive"
+    (= 1e6 (fold-right (lambda (x y) (+ 1 y))
+                       0
+                       (iota 1e6)))))
+;;
 ;; unfold
 ;;