ikarus/src/ikarus.pairs.ss

330 lines
10 KiB
Scheme
Raw Normal View History

2006-12-07 02:48:31 -05:00
2007-05-05 05:06:32 -04:00
(library (ikarus pairs)
(export
cons weak-cons set-car! set-cdr!
car cdr caar cdar cadr cddr caaar cdaar cadar cddar caadr cdadr
caddr cdddr caaaar cdaaar cadaar cddaar caadar cdadar caddar
cdddar caaadr cdaadr cadadr cddadr caaddr cdaddr cadddr cddddr)
(import
(only (ikarus) define if lambda pair? error quote let unless
foreign-call)
(rename (only (scheme) cons $car $cdr $set-car! $set-cdr!)
2007-05-05 05:07:49 -04:00
(cons sys:cons)))
2007-04-30 00:35:28 -04:00
2007-05-05 05:07:49 -04:00
(define cons (lambda (x y) (sys:cons x y)))
(define weak-cons
(lambda (a d)
(foreign-call "ikrt_weak_cons" a d)))
(define set-car!
(lambda (x y)
(unless (pair? x)
(error 'set-car! "~s is not a pair" x))
($set-car! x y)))
(define set-cdr!
(lambda (x y)
(unless (pair? x)
(error 'set-cdr! "~s is not a pair" x))
($set-cdr! x y)))
2007-04-30 00:35:28 -04:00
(define err
(lambda (who x)
(error who "invalid list structure ~s" x)))
(define car
(lambda (orig)
(if (pair? orig) ($car orig) (err 'car orig))))
(define cdr
(lambda (orig)
(if (pair? orig) ($cdr orig) (err 'cdr orig))))
(define caar
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x) ($car x) (err 'caar orig)))
(err 'caar orig))))
(define cadr
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x) ($car x) (err 'cadr orig)))
(err 'cadr orig))))
(define cdar
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x) ($cdr x) (err 'cdar orig)))
(err 'cdar orig))))
(define cddr
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x) ($cdr x) (err 'cddr orig)))
(err 'cddr orig))))
(define caaar
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x) ($car x) (err 'caaar orig)))
(err 'caaar orig)))
(err 'caaar orig))))
(define caadr
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x) ($car x) (err 'caadr orig)))
(err 'caadr orig)))
(err 'caadr orig))))
(define cadar
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x) ($car x) (err 'cadar orig)))
(err 'cadar orig)))
(err 'cadar orig))))
(define caddr
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x) ($car x) (err 'caddr orig)))
(err 'caddr orig)))
(err 'caddr orig))))
(define cdaar
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x) ($cdr x) (err 'cdaar orig)))
(err 'cdaar orig)))
(err 'cdaar orig))))
(define cdadr
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x) ($cdr x) (err 'cdadr orig)))
(err 'cdadr orig)))
(err 'cdadr orig))))
(define cddar
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x) ($cdr x) (err 'cddar orig)))
(err 'cddar orig)))
(err 'cddar orig))))
(define cdddr
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x) ($cdr x) (err 'cdddr orig)))
(err 'cdddr orig)))
(err 'cdddr orig))))
(define caaaar
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x) ($car x) (err 'caaaar orig)))
(err 'caaaar orig)))
(err 'caaaar orig)))
(err 'caaaar orig))))
(define caaadr
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x) ($car x) (err 'caaadr orig)))
(err 'caaadr orig)))
(err 'caaadr orig)))
(err 'caaadr orig))))
(define caadar
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x) ($car x) (err 'caadar orig)))
(err 'caadar orig)))
(err 'caadar orig)))
(err 'caadar orig))))
(define caaddr
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x) ($car x) (err 'caaddr orig)))
(err 'caaddr orig)))
(err 'caaddr orig)))
(err 'caaddr orig))))
(define cadaar
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x) ($car x) (err 'cadaar orig)))
(err 'cadaar orig)))
(err 'cadaar orig)))
(err 'cadaar orig))))
(define cadadr
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x) ($car x) (err 'cadadr orig)))
(err 'cadadr orig)))
(err 'cadadr orig)))
(err 'cadadr orig))))
(define caddar
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x) ($car x) (err 'caddar orig)))
(err 'caddar orig)))
(err 'caddar orig)))
(err 'caddar orig))))
(define cadddr
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x) ($car x) (err 'cadddr orig)))
(err 'cadddr orig)))
(err 'cadddr orig)))
(err 'cadddr orig))))
(define cdaaar
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x) ($cdr x) (err 'cdaaar orig)))
(err 'cdaaar orig)))
(err 'cdaaar orig)))
(err 'cdaaar orig))))
(define cdaadr
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x) ($cdr x) (err 'cdaadr orig)))
(err 'cdaadr orig)))
(err 'cdaadr orig)))
(err 'cdaadr orig))))
(define cdadar
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x) ($cdr x) (err 'cdadar orig)))
(err 'cdadar orig)))
(err 'cdadar orig)))
(err 'cdadar orig))))
(define cdaddr
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x) ($cdr x) (err 'cdaddr orig)))
(err 'cdaddr orig)))
(err 'cdaddr orig)))
(err 'cdaddr orig))))
(define cddaar
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x) ($cdr x) (err 'cddaar orig)))
(err 'cddaar orig)))
(err 'cddaar orig)))
(err 'cddaar orig))))
(define cddadr
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x)
(let ([x ($car x)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x) ($cdr x) (err 'cddadr orig)))
(err 'cddadr orig)))
(err 'cddadr orig)))
(err 'cddadr orig))))
(define cdddar
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x) ($cdr x) (err 'cdddar orig)))
(err 'cdddar orig)))
(err 'cdddar orig)))
(err 'cdddar orig))))
(define cddddr
2006-11-23 19:38:26 -05:00
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x)
(let ([x ($cdr x)])
(if (pair? x) ($cdr x) (err 'cddddr orig)))
(err 'cddddr orig)))
(err 'cddddr orig)))
(err 'cddddr orig)))))