SRFI-1: Make `unfold' tail-recursive (fix bug #30071).

* module/srfi/srfi-1.scm (unfold): Make tail-recursive, following a
  suggestion by Szavai Gyula.

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

diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm
index d7ef6bb..1e006c7 100644 (file)
--- a/module/srfi/srfi-1.scm
+++ b/module/srfi/srfi-1.scm
@@ -454,11 +454,20 @@ that result.  See the manual for details."
        (apply kons (append! lists (list (f (map1 cdr lists)))))))))
 
 (define* (unfold p f g seed #:optional (tail-gen (lambda (x) '())))
-  (let uf ((seed seed))
+  (define (reverse+tail lst seed)
+    (let loop ((lst    lst)
+               (result (tail-gen seed)))
+      (if (null? lst)
+          result
+          (loop (cdr lst)
+                (cons (car lst) result)))))
+
+  (let loop ((seed   seed)
+             (result '()))
     (if (p seed)
-        (tail-gen seed)
-        (cons (f seed)
-              (uf (g seed))))))
+        (reverse+tail result seed)
+        (loop (g seed)
+              (cons (f seed) result)))))
 
 (define* (unfold-right p f g seed #:optional (tail '()))
   (let uf ((seed seed) (lis tail))

diff --git a/test-suite/tests/srfi-1.test b/test-suite/tests/srfi-1.test
index ca34e8f..8569a3d 100644 (file)
--- a/test-suite/tests/srfi-1.test
+++ b/test-suite/tests/srfi-1.test
@@ -1265,6 +1265,34 @@
             ;; lst unmodified
             (equal? '((1 2) (3 4) (5 6)) lst))))))
 
+;;
+;; unfold
+;;
+
+(with-test-prefix "unfold"
+
+  (pass-if "basic"
+    (equal? (iota 10)
+            (unfold (lambda (x) (>= x 10))
+                    identity
+                    1+
+                    0)))
+
+  (pass-if "tail-gen"
+    (equal? (append (iota 10) '(tail 10))
+            (unfold (lambda (x) (>= x 10))
+                    identity
+                    1+
+                    0
+                    (lambda (seed) (list 'tail seed)))))
+
+  (pass-if "tail-recursive"
+    ;; Bug #30071.
+    (pair? (unfold (lambda (x) (>= x 1e6))
+                   identity
+                   1+
+                   0))))
+
 ;;
 ;; length+
 ;;