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.

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