conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* Added for-all and exists

This commit is contained in:
Abdulaziz Ghuloum 2007-10-10 03:53:42 -04:00
parent 241bdd8d4d
commit c3d410d572
3 changed files with 83 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

84
src/ikarus.lists.ss
View File

@ -852,9 +852,87 @@
(error 'partition "~s is not a procedure" p))
(race ls ls ls p))))
;;; FIXME: lost in crash.
(define for-all andmap)
(define exists ormap)
(define-syntax define-iterator
(syntax-rules ()
[(_ name combine)
(module (name)
(define who 'name)
(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 a h t ls)
(if (pair? h)
(let ([b (car h)] [h (cdr h)])
(combine (f a)
(if (pair? h)
(if (eq? h t)
(error who "~s is circular" ls)
(let ([c (car h)] [h (cdr h)])
(combine (f b) (loop1 f c h (cdr t) ls))))
(if (null? h)
(f b)
(combine (f b) (error who "~s is not a proper list" ls))))))
(if (null? h)
(f a)
(combine (f a) (error who "~s is not a proper list" ls)))))
(define (loopn f a a* h h* t ls ls*)
(if (pair? h)
(let-values ([(b* h*) (cars+cdrs h* ls*)])
(let ([b (car h)] [h (cdr h)])
(combine (apply f a a*)
(if (pair? h)
(if (eq? h t)
(error who "~s is circular" ls)
(let-values ([(c* h*) (cars+cdrs h* ls*)])
(let ([c (car h)] [h (cdr h)])
(combine (apply f b b*)
(loopn f c c* h h* (cdr t) ls ls*)))))
(if (and (null? h) (null*? h*))
(apply f b b*)
(combine (apply f b b*) (err* (cons ls ls*))))))))
(if (and (null? h) (null*? h*))
(apply f a a*)
(combine (apply f a a*) (err* (cons ls ls*))))))
(define name
(case-lambda
[(f ls)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(if (pair? ls)
(loop1 f (car ls) (cdr ls) (cdr ls) ls)
(if (null? ls)
(combine)
(error who "~s is not a list" ls)))]
[(f ls . ls*)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(if (pair? ls)
(let-values ([(cars cdrs) (cars+cdrs ls* ls*)])
(loopn f (car ls) cars (cdr ls) cdrs (cdr ls) ls ls*))
(if (and (null? ls) (null*? ls*))
(combine)
(err* ls*)))])))]))
(define-iterator for-all and)
(define-iterator exists or)
)

4
src/todo-r6rs.ss
View File

@ -512,8 +512,8 @@
[find C ls]
[fold-left S ls]
[fold-right S ls]
[for-all S ls]
[exists S ls]
[for-all C ls]
[exists C ls]
[member C ls se]
[memp C ls]
[memq C ls se]