327 lines
9.9 KiB
Scheme
327 lines
9.9 KiB
Scheme
(let ([err (lambda (who x)
|
|
(error who "invalid list structure ~s" x))])
|
|
(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))))
|
|
(primitive-set!
|
|
'caar
|
|
(lambda (orig)
|
|
(if (pair? orig)
|
|
(let ([x ($car orig)])
|
|
(if (pair? x) ($car x) (err 'caar orig)))
|
|
(err 'caar orig))))
|
|
(primitive-set!
|
|
'cadr
|
|
(lambda (orig)
|
|
(if (pair? orig)
|
|
(let ([x ($cdr orig)])
|
|
(if (pair? x) ($car x) (err 'cadr orig)))
|
|
(err 'cadr orig))))
|
|
(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)))))
|