325 lines
10 KiB
Scheme
325 lines
10 KiB
Scheme
|
|
|
|
(library (ikarus pairs)
|
|
(export
|
|
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)
|
|
(rename (only (scheme) cons $car $cdr $set-car! $set-cdr!)
|
|
(cons sys:cons)))
|
|
|
|
(define cons (lambda (x y) (sys:cons x y)))
|
|
|
|
(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)))
|
|
|
|
(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
|
|
(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
|
|
(lambda (orig)
|
|
(if (pair? orig)
|
|
(let ([x ($car orig)])
|
|
(if (pair? x) ($cdr x) (err 'cdar orig)))
|
|
(err 'cdar orig))))
|
|
(define cddr
|
|
(lambda (orig)
|
|
(if (pair? orig)
|
|
(let ([x ($cdr orig)])
|
|
(if (pair? x) ($cdr x) (err 'cddr orig)))
|
|
(err 'cddr orig))))
|
|
(define caaar
|
|
(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
|
|
(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
|
|
(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
|
|
(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
|
|
(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
|
|
(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
|
|
(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
|
|
(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
|
|
(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
|
|
(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
|
|
(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
|
|
(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
|
|
(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
|
|
(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
|
|
(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
|
|
(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
|
|
(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
|
|
(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
|
|
(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
|
|
(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
|
|
(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
|
|
(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
|
|
(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
|
|
(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)))))
|