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) (define (fold-right kons knil clist1 . rest)
(if (null? rest) (if (null? rest)
(let f ((list1 clist1)) (let loop ((lst (reverse clist1))
(if (null? list1) (result knil))
knil (if (null? lst)
(kons (car list1) (f (cdr list1))))) result
(let f ((lists (cons clist1 rest))) (loop (cdr lst)
(if (any null? lists) (kons (car lst) result))))
knil (let loop ((lists (map1 reverse (cons clist1 rest)))
(apply kons (append! (map1 car lists) (list (f (map1 cdr lists))))))))) (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) (define (pair-fold kons knil clist1 . rest)
(if (null? 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)))))) (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 ;; unfold
;; ;;