mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 03:40:34 +02:00
Code Activity

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

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

* test-suite/tests/srfi-1.test ("fold-right"): New test prefix.
This commit is contained in:
Ludovic Courtès 2010-10-08 10:43:59 +02:00
parent 07076c1e61
commit a6505cb49c
2 changed files with 34 additions and 8 deletions
Download patch file Download diff file Expand all files Collapse all files

20
module/srfi/srfi-1.scm
View file

@ -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)

22
test-suite/tests/srfi-1.test
View file

@ -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
;;