diff --git a/src/ikarus.boot b/src/ikarus.boot index 6d8f0e3..e6c9613 100644 Binary files a/src/ikarus.boot and b/src/ikarus.boot differ diff --git a/src/ikarus.lists.ss b/src/ikarus.lists.ss index 82d4468..d26a3ad 100644 --- a/src/ikarus.lists.ss +++ b/src/ikarus.lists.ss @@ -3,7 +3,7 @@ (export $memq list? list cons* make-list append length list-ref reverse last-pair memq memp memv member find assq assp assv assoc remq remv remove remp filter map for-each andmap ormap list-tail - partition for-all exists) + partition for-all exists fold-left fold-right) (import (ikarus system $fx) (ikarus system $pairs) @@ -11,7 +11,7 @@ last-pair length list-ref memq memp memv member find assq assp assv assoc remq remv remove remp filter map for-each andmap ormap list-tail partition - for-all exists)) + for-all exists fold-left fold-right)) (define $memq (lambda (x ls) @@ -934,5 +934,137 @@ (define-iterator for-all and) (define-iterator exists or) + (module (fold-left) + (define who 'fold-left) + (define (null*? ls) + (or (null? ls) (and (null? (car ls)) (null*? (cdr ls))))) + (define (err* ls*) + (if (null? ls*) + (error who "length mismatch") + (if (list? (car ls*)) + (err* (cdr ls*)) + (error who "~s is not a proper list" (car ls*))))) + (define (cars+cdrs ls ls*) + (cond + [(null? ls) (values '() '())] + [else + (let ([a (car ls)]) + (if (pair? a) + (let-values ([(cars cdrs) (cars+cdrs (cdr ls) (cdr ls*))]) + (values (cons (car a) cars) (cons (cdr a) cdrs))) + (if (list? (car ls*)) + (error who "length mismatch") + (error who "~s is not a proper list" (car ls*)))))])) + (define (loop1 f nil h t ls) + (if (pair? h) + (let ([a (car h)] [h (cdr h)]) + (if (pair? h) + (if (eq? h t) + (error who "~s is circular" ls) + (let ([b (car h)] [h (cdr h)] [t (cdr t)]) + (loop1 f (f (f nil a) b) h t ls))) + (if (null? h) + (f nil a) + (error who "~s is not a proper list" ls)))) + (if (null? h) + nil + (error who "~s is not a proper list" ls)))) + (define (loopn f nil h h* t ls ls*) + (if (pair? h) + (let-values ([(a* h*) (cars+cdrs h* ls*)]) + (let ([a (car h)] [h (cdr h)]) + (if (pair? h) + (if (eq? h t) + (error who "~s is circular" ls) + (let-values ([(b* h*) (cars+cdrs h* ls*)]) + (let ([b (car h)] [h (cdr h)] [t (cdr t)]) + (loopn f + (apply f (apply f nil a a*) b b*) + h h* t ls ls*)))) + (if (and (null? h) (null*? h*)) + (apply f nil a a*) + (err* (cons ls ls*)))))) + (if (and (null? h) (null*? h*)) + nil + (err* (cons ls ls*))))) + (define fold-left + (case-lambda + [(f nil ls) + (unless (procedure? f) + (error who "~s is not a procedure" f)) + (loop1 f nil ls ls ls)] + [(f nil ls . ls*) + (unless (procedure? f) + (error who "~s is not a procedure" f)) + (loopn f nil ls ls* ls ls ls*)]))) + + (module (fold-right) + (define who 'fold-right) + (define (null*? ls) + (or (null? ls) (and (null? (car ls)) (null*? (cdr ls))))) + (define (err* ls*) + (if (null? ls*) + (error who "length mismatch") + (if (list? (car ls*)) + (err* (cdr ls*)) + (error who "~s is not a proper list" (car ls*))))) + (define (cars+cdrs ls ls*) + (cond + [(null? ls) (values '() '())] + [else + (let ([a (car ls)]) + (if (pair? a) + (let-values ([(cars cdrs) (cars+cdrs (cdr ls) (cdr ls*))]) + (values (cons (car a) cars) (cons (cdr a) cdrs))) + (if (list? (car ls*)) + (error who "length mismatch") + (error who "~s is not a proper list" (car ls*)))))])) + (define (loop1 f nil h t ls) + (if (pair? h) + (let ([a (car h)] [h (cdr h)]) + (if (pair? h) + (if (eq? h t) + (error who "~s is circular" ls) + (let ([b (car h)] [h (cdr h)] [t (cdr t)]) + (f a (f b (loop1 f nil h t ls))))) + (if (null? h) + (f a nil) + (error who "~s is not a proper list" ls)))) + (if (null? h) + nil + (error who "~s is not a proper list" ls)))) + (define (loopn f nil h h* t ls ls*) + (if (pair? h) + (let-values ([(a* h*) (cars+cdrs h* ls*)]) + (let ([a (car h)] [h (cdr h)]) + (if (pair? h) + (if (eq? h t) + (error who "~s is circular" ls) + (let-values ([(b* h*) (cars+cdrs h* ls*)]) + (let ([b (car h)] [h (cdr h)] [t (cdr t)]) + (apply f a + (append a* + (list + (apply f + b (append b* + (list (loopn f nil h h* t ls ls*)))))))))) + (if (and (null? h) (null*? h*)) + (apply f a (append a* (list nil))) + (err* (cons ls ls*)))))) + (if (and (null? h) (null*? h*)) + nil + (err* (cons ls ls*))))) + (define fold-right + (case-lambda + [(f nil ls) + (unless (procedure? f) + (error who "~s is not a procedure" f)) + (loop1 f nil ls ls ls)] + [(f nil ls . ls*) + (unless (procedure? f) + (error who "~s is not a procedure" f)) + (loopn f nil ls ls* ls ls ls*)] + ))) + ) diff --git a/src/makefile.ss b/src/makefile.ss index ea16989..85afd7c 100755 --- a/src/makefile.ss +++ b/src/makefile.ss @@ -933,8 +933,8 @@ [cons* i r ls] [filter i r ls] [find i r ls] - [fold-left r ls] - [fold-right r ls] + [fold-left i r ls] + [fold-right i r ls] [for-all i r ls] [exists i r ls] [member i r ls se] diff --git a/src/tests/lists.ss b/src/tests/lists.ss index af325da..e65a1eb 100644 --- a/src/tests/lists.ss +++ b/src/tests/lists.ss @@ -15,5 +15,29 @@ [values (equal? (for-all cons '(1 2 3) '(a b c)) '(3 . c))] [values (equal? (for-all (lambda (a b) (= a 1)) '(1 2 3) '(a b c)) #f)] [values (equal? (for-all (lambda (a b) (= a 1)) '(1 2) '(a b c)) #f)] + [values (equal? (fold-left + 0 '(1 2 3 4 5)) 15)] + [values (equal? (fold-left (lambda (a b) (cons b a)) '() '(1 2 3 4 5)) + '(5 4 3 2 1))] + [values (equal? (fold-left (lambda (count x) + (if (odd? x) + (+ count 1) + count)) + 0 + '(3 1 4 1 5 9 2 6 5 3)) + 7)] + [values (equal? (fold-left cons '(q) '(a b c)) '((((q) . a) . b) . c))] + [values (equal? (fold-left + 0 '(1 2 3) '(4 5 6)) 21)] + [values (equal? (fold-right + 0 '(1 2 3 4 5)) 15)] + [values (equal? (fold-right cons '() '(1 2 3 4 5)) + '(1 2 3 4 5))] + [values (equal? (fold-right (lambda (x l) + (if (odd? x) + (cons x l) + l)) + '() + '(3 1 4 1 5 9 2 6 5 3)) + '(3 1 1 5 9 5 3))] + [values (equal? (fold-right + 0 '(1 2 3) '(4 5 6)) 21)] )) - + + diff --git a/src/todo-r6rs.ss b/src/todo-r6rs.ss index e3dd991..beb269e 100755 --- a/src/todo-r6rs.ss +++ b/src/todo-r6rs.ss @@ -510,8 +510,8 @@ [cons* C ls] [filter C ls] [find C ls] - [fold-left S ls] - [fold-right S ls] + [fold-left C ls] + [fold-right C ls] [for-all C ls] [exists C ls] [member C ls se]