artemist/mes
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

mes: Support fold-right 3.

Browse source 
* mes/module/srfi/srfi-1.mes (fold-right): Support fold-right 3.
* tests/srfi-1.test ("fold-right-3"): Test it.
This commit is contained in:
Jan Nieuwenhuizen 2018-10-06 21:05:43 +02:00
parent 6ab9a206bb
commit b31d431b5d
No known key found for this signature in database
GPG key ID: F3C1A0D9C1D65273
2 changed files with 19 additions and 1 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

12
mes/module/srfi/srfi-1.mes
View file

@ -74,7 +74,17 @@
(let loop ((lst lst1))
(if (null? lst) init
(proc (car lst) (loop (cdr lst)))))
(error "FOLD-RIGHT-2-NOT-SUPPORTED")))
(if (null? (cdr rest))
(let loop ((lst1 lst1) (lst2 (car rest)))
(if (or (null? lst1)
(null? lst2)) init
(proc (car lst1) (car lst2) (loop (cdr lst1) (cdr lst2)))))
(let loop ((lst1 lst1) (lst2 (car rest)) (lst3 (cadr rest)))
(if (or (null? lst1)
(null? lst2)
(null? lst3)) init
(proc (car lst1) (car lst2) (car lst3) (loop (cdr lst1) (cdr lst2) (cdr lst3)))))
(error "FOLD-RIGHT-4-NOT-SUPPORTED"))))
(define (unfold p f g seed . rest)
(let ((tail-gen (if (null? rest) (const '())

8
tests/srfi-1.test
View file

@ -65,4 +65,12 @@ exec ${MES-src/mes} --no-auto-compile -L ${0%/*} -L module -C module -e '(tests
'(0 0 1)
(append-map iota '(1 2)))
(pass-if-equal "fold-3"
'(1 A a 2 B b 3 C c)
(fold cons* '() '(3 2 1) '(C B A) '(c b a)))
(pass-if-equal "fold-right-3"
'(1 A a 2 B b 3 C c)
(fold-right cons* '() '(1 2 3) '(A B C) '(a b c)))
(result 'report)