diff options
| author | Ludovic Courtès <ludo@gnu.org> | 2010-10-08 10:23:52 +0200 |
|---|---|---|
| committer | Ludovic Courtès <ludo@gnu.org> | 2010-10-08 15:25:56 +0200 |
| commit | 07076c1e61ab05b62979ee01a5220edb308b0750 (patch) | |
| tree | f64541ed8e206a3fc02e5e919b1a53b78dfbbd96 | |
| parent | c00623281b8272388b673996d94f6e4b9146f909 (diff) | |
| download | guile-07076c1e61ab05b62979ee01a5220edb308b0750.tar.gz | |
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.
| -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 d7ef6bb..1e006c7 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 ca34e8f..8569a3d 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+ ;; |
