From b31d431b5d8881e08f1c2740a4a7d636c20c8450 Mon Sep 17 00:00:00 2001 From: Jan Nieuwenhuizen Date: Sat, 6 Oct 2018 21:05:43 +0200 Subject: [PATCH] mes: Support fold-right 3. * mes/module/srfi/srfi-1.mes (fold-right): Support fold-right 3. * tests/srfi-1.test ("fold-right-3"): Test it. --- mes/module/srfi/srfi-1.mes | 12 +++++++++++- tests/srfi-1.test | 8 ++++++++ 2 files changed, 19 insertions(+), 1 deletion(-) diff --git a/mes/module/srfi/srfi-1.mes b/mes/module/srfi/srfi-1.mes index 84bf44b6..3b345838 100644 --- a/mes/module/srfi/srfi-1.mes +++ b/mes/module/srfi/srfi-1.mes @@ -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 '()) diff --git a/tests/srfi-1.test b/tests/srfi-1.test index b7f0028f..03235473 100755 --- a/tests/srfi-1.test +++ b/tests/srfi-1.test @@ -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)