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

* moved memq, memv, and member to ikarus.lists

This commit is contained in:
Abdulaziz Ghuloum 2007-05-05 05:26:38 -04:00
parent 4a24e5ed28
commit 6a381a70f8
3 changed files with 67 additions and 66 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.

63
src/ikarus.core.ss
View File

@ -65,71 +65,8 @@
(primitive-set! 'memq
(letrec ([race
(lambda (h t ls x)
(if (pair? h)
(if (eq? ($car h) x)
h
(let ([h ($cdr h)])
(if (pair? h)
(if (eq? ($car h) x)
h
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls x)
(error 'memq "circular list ~s" ls)))
(if (null? h)
'#f
(error 'memq "~s is not a proper list" ls)))))
(if (null? h)
'#f
(error 'memq "~s is not a proper list" ls))))])
(lambda (x ls)
(race ls ls ls x))))
(primitive-set! 'memv
(letrec ([race
(lambda (h t ls x)
(if (pair? h)
(if (eqv? ($car h) x)
h
(let ([h ($cdr h)])
(if (pair? h)
(if (eqv? ($car h) x)
h
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls x)
(error 'memv "circular list ~s" ls)))
(if (null? h)
'#f
(error 'memv "~s is not a proper list" ls)))))
(if (null? h)
'#f
(error 'memv "~s is not a proper list" ls))))])
(lambda (x ls)
(race ls ls ls x))))
(primitive-set! 'member
(letrec ([race
(lambda (h t ls x)
(if (pair? h)
(if (equal? ($car h) x)
h
(let ([h ($cdr h)])
(if (pair? h)
(if (equal? ($car h) x)
h
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls x)
(error 'member "circular list ~s" ls)))
(if (null? h)
'#f
(error 'member "~s is not a proper list" ls)))))
(if (null? h)
'#f
(error 'member "~s is not a proper list" ls))))])
(lambda (x ls)
(race ls ls ls x))))

70
src/ikarus.lists.ss
View File

@ -1,10 +1,10 @@
(library (ikarus lists)
(export $memq list? reverse last-pair)
(export $memq list? reverse last-pair memq memv member)
(import
(only (scheme) $car $cdr)
(except (ikarus) list? reverse last-pair))
(except (ikarus) list? reverse last-pair memq memv member))
(define $memq
(lambda (x ls)
@ -61,8 +61,72 @@
(let ([d (cdr x)])
(race d d x x))
(error 'last-pair "~s is not a pair" x)))))
(define memq
(letrec ([race
(lambda (h t ls x)
(if (pair? h)
(if (eq? ($car h) x)
h
(let ([h ($cdr h)])
(if (pair? h)
(if (eq? ($car h) x)
h
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls x)
(error 'memq "circular list ~s" ls)))
(if (null? h)
'#f
(error 'memq "~s is not a proper list" ls)))))
(if (null? h)
'#f
(error 'memq "~s is not a proper list" ls))))])
(lambda (x ls)
(race ls ls ls x))))
(define memv
(letrec ([race
(lambda (h t ls x)
(if (pair? h)
(if (eqv? ($car h) x)
h
(let ([h ($cdr h)])
(if (pair? h)
(if (eqv? ($car h) x)
h
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls x)
(error 'memv "circular list ~s" ls)))
(if (null? h)
'#f
(error 'memv "~s is not a proper list" ls)))))
(if (null? h)
'#f
(error 'memv "~s is not a proper list" ls))))])
(lambda (x ls)
(race ls ls ls x))))
(define member
(letrec ([race
(lambda (h t ls x)
(if (pair? h)
(if (equal? ($car h) x)
h
(let ([h ($cdr h)])
(if (pair? h)
(if (equal? ($car h) x)
h
(if (not (eq? h t))
(race ($cdr h) ($cdr t) ls x)
(error 'member "circular list ~s" ls)))
(if (null? h)
'#f
(error 'member "~s is not a proper list" ls)))))
(if (null? h)
'#f
(error 'member "~s is not a proper list" ls))))])
(lambda (x ls)
(race ls ls ls x))))
)