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

* moved assq, assv, and assoc to ikarus.lists

This commit is contained in:
Abdulaziz Ghuloum 2007-05-05 05:31:30 -04:00
parent 4a6f340ce2
commit f49897fadf
3 changed files with 86 additions and 84 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.

81
src/ikarus.core.ss
View File

@ -74,89 +74,8 @@
(primitive-set! 'assq
(letrec ([race
(lambda (x h t ls)
(if (pair? h)
(let ([a ($car h)] [h ($cdr h)])
(if (pair? a)
(if (eq? ($car a) x)
a
(if (pair? h)
(if (not (eq? h t))
(let ([a ($car h)])
(if (pair? a)
(if (eq? ($car a) x)
a
(race x ($cdr h) ($cdr t) ls))
(error 'assq "malformed alist ~s"
ls)))
(error 'assq "circular list ~s" ls))
(if (null? h)
#f
(error 'assq "~s is not a proper list" ls))))
(error 'assq "malformed alist ~s" ls)))
(if (null? h)
#f
(error 'assq "~s is not a proper list" ls))))])
(lambda (x ls)
(race x ls ls ls))))
(primitive-set! 'assv
(letrec ([race
(lambda (x h t ls)
(if (pair? h)
(let ([a ($car h)] [h ($cdr h)])
(if (pair? a)
(if (eqv? ($car a) x)
a
(if (pair? h)
(if (not (eq? h t))
(let ([a ($car h)])
(if (pair? a)
(if (eqv? ($car a) x)
a
(race x ($cdr h) ($cdr t) ls))
(error 'assv "malformed alist ~s"
ls)))
(error 'assv "circular list ~s" ls))
(if (null? h)
#f
(error 'assv "~s is not a proper list" ls))))
(error 'assv "malformed alist ~s" ls)))
(if (null? h)
#f
(error 'assv "~s is not a proper list" ls))))])
(lambda (x ls)
(race x ls ls ls))))
(primitive-set! 'assoc
(letrec ([race
(lambda (x h t ls)
(if (pair? h)
(let ([a ($car h)] [h ($cdr h)])
(if (pair? a)
(if (equal? ($car a) x)
a
(if (pair? h)
(if (not (eq? h t))
(let ([a ($car h)])
(if (pair? a)
(if (equal? ($car a) x)
a
(race x ($cdr h) ($cdr t) ls))
(error 'assoc "malformed alist ~s"
ls)))
(error 'assoc "circular list ~s" ls))
(if (null? h)
#f
(error 'assoc "~s is not a proper list" ls))))
(error 'assoc "malformed alist ~s" ls)))
(if (null? h)
#f
(error 'assoc "~s is not a proper list" ls))))])
(lambda (x ls)
(race x ls ls ls))))
(primitive-set! 'string->symbol (primitive-set! 'string->symbol

89
src/ikarus.lists.ss
View File

@ -1,12 +1,12 @@
(library (ikarus lists) (library (ikarus lists)
(export $memq list? length list-ref reverse last-pair (export $memq list? length list-ref reverse last-pair
memq memv member) memq memv member assq assv assoc)
(import (import
(only (scheme) $car $cdr $fx+ $fxsub1 $fxzero? $fx>=) (only (scheme) $car $cdr $fx+ $fxsub1 $fxzero? $fx>=)
(except (ikarus) list? reverse last-pair memq memv member (except (ikarus) list? reverse last-pair length list-ref
length list-ref)) memq memv member assq assv assoc))
(define $memq (define $memq
(lambda (x ls) (lambda (x ls)
@ -165,6 +165,89 @@
(lambda (x ls) (lambda (x ls)
(race ls ls ls x)))) (race ls ls ls x))))
(define assq
(letrec ([race
(lambda (x h t ls)
(if (pair? h)
(let ([a ($car h)] [h ($cdr h)])
(if (pair? a)
(if (eq? ($car a) x)
a
(if (pair? h)
(if (not (eq? h t))
(let ([a ($car h)])
(if (pair? a)
(if (eq? ($car a) x)
a
(race x ($cdr h) ($cdr t) ls))
(error 'assq "malformed alist ~s"
ls)))
(error 'assq "circular list ~s" ls))
(if (null? h)
#f
(error 'assq "~s is not a proper list" ls))))
(error 'assq "malformed alist ~s" ls)))
(if (null? h)
#f
(error 'assq "~s is not a proper list" ls))))])
(lambda (x ls)
(race x ls ls ls))))
(define assv
(letrec ([race
(lambda (x h t ls)
(if (pair? h)
(let ([a ($car h)] [h ($cdr h)])
(if (pair? a)
(if (eqv? ($car a) x)
a
(if (pair? h)
(if (not (eq? h t))
(let ([a ($car h)])
(if (pair? a)
(if (eqv? ($car a) x)
a
(race x ($cdr h) ($cdr t) ls))
(error 'assv "malformed alist ~s"
ls)))
(error 'assv "circular list ~s" ls))
(if (null? h)
#f
(error 'assv "~s is not a proper list" ls))))
(error 'assv "malformed alist ~s" ls)))
(if (null? h)
#f
(error 'assv "~s is not a proper list" ls))))])
(lambda (x ls)
(race x ls ls ls))))
(define assoc
(letrec ([race
(lambda (x h t ls)
(if (pair? h)
(let ([a ($car h)] [h ($cdr h)])
(if (pair? a)
(if (equal? ($car a) x)
a
(if (pair? h)
(if (not (eq? h t))
(let ([a ($car h)])
(if (pair? a)
(if (equal? ($car a) x)
a
(race x ($cdr h) ($cdr t) ls))
(error 'assoc "malformed alist ~s"
ls)))
(error 'assoc "circular list ~s" ls))
(if (null? h)
#f
(error 'assoc "~s is not a proper list" ls))))
(error 'assoc "malformed alist ~s" ls)))
(if (null? h)
#f
(error 'assoc "~s is not a proper list" ls))))])
(lambda (x ls)
(race x ls ls ls))))
) )