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

* moved andmap and ormap to ikarus.lists

This commit is contained in:
Abdulaziz Ghuloum 2007-05-05 06:02:02 -04:00
parent a6faa9fb39
commit f3472d2f71
3 changed files with 126 additions and 123 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.

121
src/ikarus.core.ss
View File

@ -167,129 +167,8 @@
(let ()
(define who 'andmap)
(define len
(lambda (h t n)
(if (pair? h)
(let ([h ($cdr h)])
(if (pair? h)
(if (eq? h t)
(error who "circular list")
(len ($cdr h) ($cdr t) ($fx+ n 2)))
(if (null? h)
($fxadd1 n)
(error who "improper list"))))
(if (null? h)
n
(error who "improper list")))))
(define andmap1
(lambda (f a d n)
(cond
[(pair? d)
(if ($fxzero? n)
(error who "list was altered!")
(and (f a)
(andmap1 f ($car d) ($cdr d) ($fxsub1 n))))]
[(null? d)
(if ($fxzero? n)
(f a)
(error who "list was altered"))]
[else (error who "list was altered")])))
(define andmap2
(lambda (f a1 a2 d1 d2 n)
(cond
[(pair? d1)
(cond
[(pair? d2)
(if ($fxzero? n)
(error who "list was altered")
(and
(f a1 a2)
(andmap2 f
($car d1) ($car d2)
($cdr d1) ($cdr d2)
($fxsub1 n))))]
[else (error who "length mismatch")])]
[(null? d1)
(cond
[(null? d2)
(if ($fxzero? n)
(f a1 a2)
(error who "list was altered"))]
[else (error who "length mismatch")])]
[else (error who "list was altered")])))
(primitive-set! 'andmap
(case-lambda
[(f ls)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(cond
[(pair? ls)
(let ([d ($cdr ls)])
(andmap1 f ($car ls) d (len d d 0)))]
[(null? ls) #t]
[else (error who "improper list")])]
[(f ls ls2)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(cond
[(pair? ls)
(if (pair? ls2)
(let ([d ($cdr ls)])
(andmap2 f
($car ls) ($car ls2) d ($cdr ls2) (len d d 0)))
(error who "length mismatch"))]
[(null? ls)
(if (null? ls2)
#t
(error who "length mismatch"))]
[else (error who "not a list")])]
[(f . ls*) (error who "vararg not supported yet in ~s"
(length ls*))])))
(let ()
(define who 'ormap)
(define len
(lambda (h t n)
(if (pair? h)
(let ([h ($cdr h)])
(if (pair? h)
(if (eq? h t)
(error who "circular list")
(len ($cdr h) ($cdr t) ($fx+ n 2)))
(if (null? h)
($fxadd1 n)
(error who "improper list"))))
(if (null? h)
n
(error who "improper list")))))
(define ormap1
(lambda (f a d n)
(cond
[(pair? d)
(if ($fxzero? n)
(error who "list was altered!")
(or (f a)
(ormap1 f ($car d) ($cdr d) ($fxsub1 n))))]
[(null? d)
(if ($fxzero? n)
(f a)
(error who "list was altered"))]
[else (error who "list was altered")])))
(primitive-set! 'ormap
(case-lambda
[(f ls)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(cond
[(pair? ls)
(let ([d ($cdr ls)])
(ormap1 f ($car ls) d (len d d 0)))]
[(null? ls) #f]
[else (error who "improper list")])]
[_ (error who "vararg not supported yet")])))

128
src/ikarus.lists.ss
View File

@ -2,12 +2,12 @@
(library (ikarus lists)
(export $memq list? length list-ref reverse last-pair
memq memv member assq assv assoc
map for-each)
map for-each andmap ormap)
(import
(only (scheme) $car $cdr $fx+ $fxadd1 $fxsub1 $fxzero? $fx>=)
(except (ikarus) list? reverse last-pair length list-ref
memq memv member assq assv assoc
map for-each))
map for-each andmap ormap))
(define $memq
(lambda (x ls)
@ -456,5 +456,129 @@
[else (error who "not a list")])]
[_ (error who "vararg not supported yet")])))
(module (andmap)
(define who 'andmap)
(define len
(lambda (h t n)
(if (pair? h)
(let ([h ($cdr h)])
(if (pair? h)
(if (eq? h t)
(error who "circular list")
(len ($cdr h) ($cdr t) ($fx+ n 2)))
(if (null? h)
($fxadd1 n)
(error who "improper list"))))
(if (null? h)
n
(error who "improper list")))))
(define andmap1
(lambda (f a d n)
(cond
[(pair? d)
(if ($fxzero? n)
(error who "list was altered!")
(and (f a)
(andmap1 f ($car d) ($cdr d) ($fxsub1 n))))]
[(null? d)
(if ($fxzero? n)
(f a)
(error who "list was altered"))]
[else (error who "list was altered")])))
(define andmap2
(lambda (f a1 a2 d1 d2 n)
(cond
[(pair? d1)
(cond
[(pair? d2)
(if ($fxzero? n)
(error who "list was altered")
(and
(f a1 a2)
(andmap2 f
($car d1) ($car d2)
($cdr d1) ($cdr d2)
($fxsub1 n))))]
[else (error who "length mismatch")])]
[(null? d1)
(cond
[(null? d2)
(if ($fxzero? n)
(f a1 a2)
(error who "list was altered"))]
[else (error who "length mismatch")])]
[else (error who "list was altered")])))
(define andmap
(case-lambda
[(f ls)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(cond
[(pair? ls)
(let ([d ($cdr ls)])
(andmap1 f ($car ls) d (len d d 0)))]
[(null? ls) #t]
[else (error who "improper list")])]
[(f ls ls2)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(cond
[(pair? ls)
(if (pair? ls2)
(let ([d ($cdr ls)])
(andmap2 f
($car ls) ($car ls2) d ($cdr ls2) (len d d 0)))
(error who "length mismatch"))]
[(null? ls)
(if (null? ls2)
#t
(error who "length mismatch"))]
[else (error who "not a list")])]
[(f . ls*) (error who "vararg not supported yet in ~s" (length ls*))])))
(module (ormap)
(define who 'ormap)
(define len
(lambda (h t n)
(if (pair? h)
(let ([h ($cdr h)])
(if (pair? h)
(if (eq? h t)
(error who "circular list")
(len ($cdr h) ($cdr t) ($fx+ n 2)))
(if (null? h)
($fxadd1 n)
(error who "improper list"))))
(if (null? h)
n
(error who "improper list")))))
(define ormap1
(lambda (f a d n)
(cond
[(pair? d)
(if ($fxzero? n)
(error who "list was altered!")
(or (f a)
(ormap1 f ($car d) ($cdr d) ($fxsub1 n))))]
[(null? d)
(if ($fxzero? n)
(f a)
(error who "list was altered"))]
[else (error who "list was altered")])))
(define ormap
(case-lambda
[(f ls)
(unless (procedure? f)
(error who "~s is not a procedure" f))
(cond
[(pair? ls)
(let ([d ($cdr ls)])
(ormap1 f ($car ls) d (len d d 0)))]
[(null? ls) #f]
[else (error who "improper list")])]
[_ (error who "vararg not supported yet")])))
)