diff options
-rw-r--r-- | module/srfi/srfi-1.scm | 17 | ||||
-rw-r--r-- | test-suite/tests/srfi-1.test | 28 |
2 files changed, 41 insertions, 4 deletions
diff --git a/module/srfi/srfi-1.scm b/module/srfi/srfi-1.scm index d7ef6bb0c..1e006c753 100644 --- 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 ca34e8fa8..8569a3db1 100644 --- a/test-suite/tests/srfi-1.test +++ b/test-suite/tests/srfi-1.test @@ -1266,6 +1266,34 @@ (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+ ;; |