conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity
ikarus/src/libcxr.ss

338 lines
10 KiB
Scheme
Raw Normal View History

* Cadr is now open-coded.
2006-12-07 02:48:31 -05:00
* before attempting to use chaitin to compile the system.
2007-02-11 21:42:01 -05:00
;(primitive-set! 'car (lambda (x) (car x)))
;(primitive-set! 'cdr (lambda (x) (cdr x)))
;(primitive-set! 'cadr (lambda (x) (cadr x)))
* libcxr librarified
2007-04-30 00:35:28 -04:00
(library (ikarus cxr)
(export)
(import (scheme))
(define err
(lambda (who x)
(error who "invalid list structure ~s" x)))
* before attempting to use chaitin to compile the system.
2007-02-11 21:42:01 -05:00
(primitive-set!
'car
(lambda (orig)
(if (pair? orig) ($car orig) (err 'car orig))))
(primitive-set!
'cdr
(lambda (orig)
(if (pair? orig) ($cdr orig) (err 'cdr orig))))
imported compiler1
2006-11-23 19:38:26 -05:00
(primitive-set!
'caar
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x) ($car x) (err 'caar orig)))
(err 'caar orig))))
* before attempting to use chaitin to compile the system.
2007-02-11 21:42:01 -05:00
(primitive-set!
'cadr
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x) ($car x) (err 'cadr orig)))
(err 'cadr orig))))
imported compiler1
2006-11-23 19:38:26 -05:00
(primitive-set!
'cdar
(lambda (orig)
(if (pair? orig)
(let ([x ($car orig)])
(if (pair? x) ($cdr x) (err 'cdar orig)))
(err 'cdar orig))))
(primitive-set!
'cddr
(lambda (orig)
(if (pair? orig)
(let ([x ($cdr orig)])
(if (pair? x) ($cdr x) (err 'cddr orig)))
(err 'cddr orig))))
(primitive-set!
'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))))
(primitive-set!
'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))))
(primitive-set!
'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))))
(primitive-set!
'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))))
(primitive-set!
'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))))
(primitive-set!
'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))))
(primitive-set!
'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))))
(primitive-set!
'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))))
(primitive-set!
'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))))
(primitive-set!
'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))))
(primitive-set!
'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))))
(primitive-set!
'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))))
(primitive-set!
'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))))
(primitive-set!
'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))))
(primitive-set!
'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))))
(primitive-set!
'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))))
(primitive-set!
'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))))
(primitive-set!
'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))))
(primitive-set!
'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))))
(primitive-set!
'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))))
(primitive-set!
'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))))
(primitive-set!
'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))))
(primitive-set!
'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))))
(primitive-set!
'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)))))