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

* cleanup of pairs.ss

This commit is contained in:
Abdulaziz Ghuloum 2007-05-08 19:19:50 -04:00
parent 1948dd5942
commit 0e1fcc18c3
2 changed files with 51 additions and 294 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.

343
src/ikarus.pairs.ss
View File

@ -36,297 +36,54 @@
(define err (define err
(lambda (who x) (lambda (who x)
(error who "invalid list structure ~s" x))) (error who "invalid list structure ~s" x)))
(define car
(lambda (orig) (define-syntax cxr
(if (pair? orig) ($car orig) (err 'car orig)))) (syntax-rules ()
(define cdr [(_ err $car/$cdr)
(lambda (orig) (lambda (x)
(if (pair? orig) ($cdr orig) (err 'cdr orig)))) (if (pair? x) ($car/$cdr x) err))]
(define caar [(_ err rest ... $car/$cdr)
(lambda (orig) (lambda (x)
(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) (if (pair? x)
(let ([x ($car x)]) ((cxr err rest ...) ($car/$cdr x))
(if (pair? x) ($car x) (err 'caaar orig))) err))]))
(err 'caaar orig)))
(err 'caaar orig)))) (define-syntax define-cxr*
(define caadr (syntax-rules ()
(lambda (orig) [(_ [name* ops** ...] ...)
(if (pair? orig) (begin
(let ([x ($cdr orig)]) (define name*
(if (pair? x) (lambda (x) ((cxr (err 'name* x) ops** ...) x)))
(let ([x ($car x)]) ...)]))
(if (pair? x) ($car x) (err 'caadr orig)))
(err 'caadr orig))) (define-cxr*
(err 'caadr orig)))) [car $car]
(define cadar [cdr $cdr]
(lambda (orig) [caar $car $car]
(if (pair? orig) [cdar $cdr $car]
(let ([x ($car orig)]) [cadr $car $cdr]
(if (pair? x) [cddr $cdr $cdr]
(let ([x ($cdr x)]) [caaar $car $car $car]
(if (pair? x) ($car x) (err 'cadar orig))) [cdaar $cdr $car $car]
(err 'cadar orig))) [cadar $car $cdr $car]
(err 'cadar orig)))) [cddar $cdr $cdr $car]
(define caddr [caadr $car $car $cdr]
(lambda (orig) [cdadr $cdr $car $cdr]
(if (pair? orig) [caddr $car $cdr $cdr]
(let ([x ($cdr orig)]) [cdddr $cdr $cdr $cdr]
(if (pair? x) [caaaar $car $car $car $car]
(let ([x ($cdr x)]) [cdaaar $cdr $car $car $car]
(if (pair? x) ($car x) (err 'caddr orig))) [cadaar $car $cdr $car $car]
(err 'caddr orig))) [cddaar $cdr $cdr $car $car]
(err 'caddr orig)))) [caadar $car $car $cdr $car]
(define cdaar [cdadar $cdr $car $cdr $car]
(lambda (orig) [caddar $car $cdr $cdr $car]
(if (pair? orig) [cdddar $cdr $cdr $cdr $car]
(let ([x ($car orig)]) [caaadr $car $car $car $cdr]
(if (pair? x) [cdaadr $cdr $car $car $cdr]
(let ([x ($car x)]) [cadadr $car $cdr $car $cdr]
(if (pair? x) ($cdr x) (err 'cdaar orig))) [cddadr $cdr $cdr $car $cdr]
(err 'cdaar orig))) [caaddr $car $car $cdr $cdr]
(err 'cdaar orig)))) [cdaddr $cdr $car $cdr $cdr]
(define cdadr [cadddr $car $cdr $cdr $cdr]
(lambda (orig) [cddddr $cdr $cdr $cdr $cdr]))
(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)))))