diff --git a/module/mes/base-0.mes b/module/mes/base-0.mes index 78a525fd..11359fc2 100644 --- a/module/mes/base-0.mes +++ b/module/mes/base-0.mes @@ -35,13 +35,8 @@ (define (primitive-eval e) (core:eval e (current-module))) (define eval core:eval) -(define (caar x) (car (car x))) -(define (cadr x) (car (cdr x))) -(define (cdar x) (cdr (car x))) -(define (cddr x) (cdr (cdr x))) - (define-macro (defined? x) - (list 'assq x '(cddr (current-module)))) + (list 'assq x '(cdr (cdr (current-module))))) (if (defined? 'current-input-port) #t (define (current-input-port) 0)) @@ -58,7 +53,6 @@ (if (null? (cdr rest)) (car rest) (cons (car rest) (core:apply cons* (cdr rest) (current-module))))) -(define (apply f h . t) (apply-env f (cons h t) (current-module))) (define (apply f h . t) (if (null? t) (core:apply f h (current-module)) (apply f (apply cons* (cons h t))))) @@ -70,9 +64,9 @@ (cons '(test) (list (list 'if 'test - (if (pair? (cdar clauses)) - (if (eq? (cadar clauses) '=>) - (append2 (cddar clauses) '(test)) + (if (pair? (cdr (car clauses))) + (if (eq? (car (cdr (car clauses))) '=>) + (append2 (cdr (cdr (car clauses))) '(test)) (list (cons 'lambda (cons '() (car clauses))))) (list (cons 'lambda (cons '() (car clauses))))) (if (pair? (cdr clauses)) @@ -81,6 +75,7 @@ (define else #t) +(define (cadr x) (car (cdr x))) (define-macro (simple-let bindings . rest) (cons (cons 'lambda (cons (map1 car bindings) rest)) (map1 cadr bindings))) @@ -150,8 +145,8 @@ (list 'set! '*modules* (list cons (list string->symbol (module->file module)) '*modules*)) (list 'load (list string-append '*mes-prefix* (module->file module))))))) -(mes-use-module (srfi srfi-0)) (mes-use-module (mes base)) +(mes-use-module (srfi srfi-0)) (mes-use-module (mes quasiquote)) (mes-use-module (mes let)) (mes-use-module (mes scm)) diff --git a/module/mes/base.mes b/module/mes/base.mes index 3bb1e4e5..1c2f6798 100644 --- a/module/mes/base.mes +++ b/module/mes/base.mes @@ -31,15 +31,43 @@ (define (cadr x) (car (cdr x))) (define (cdar x) (cdr (car x))) (define (cddr x) (cdr (cdr x))) + + (define (caaar x) (car (car (car x)))) (define (caadr x) (car (car (cdr x)))) -(define (caddr x) (car (cdr (cdr x)))) -(define (cdadr x) (cdr (car (cdr x)))) (define (cadar x) (car (cdr (car x)))) +(define (caddr x) (car (cdr (cdr x)))) + +(define (cdaar x) (cdr (car (car x)))) +(define (cdadr x) (cdr (car (cdr x)))) (define (cddar x) (cdr (cdr (car x)))) (define (cdddr x) (cdr (cdr (cdr x)))) + + + +(define (caaaar x) (car (car (car (car x))))) +(define (caaadr x) (car (car (car (cdr x))))) +(define (caadar x) (car (car (cdr (car x))))) +(define (caaddr x) (car (car (cdr (cdr x))))) + +(define (cadaar x) (car (cdr (car (car x))))) +(define (cadadr x) (car (cdr (car (cdr x))))) +(define (caddar x) (car (cdr (cdr (car x))))) (define (cadddr x) (car (cdr (cdr (cdr x))))) + +(define (cdaaar x) (cdr (car (car (car x))))) +(define (cdaadr x) (cdr (car (car (cdr x))))) +(define (cdadar x) (cdr (car (cdr (car x))))) +(define (cdaddr x) (cdr (car (cdr (cdr x))))) + +(define (cddaar x) (cdr (cdr (car (car x))))) +(define (cddadr x) (cdr (cdr (car (cdr x))))) +(define (cdddar x) (cdr (cdr (cdr (car x))))) +(define (cddddr x) (cdr (cdr (cdr (cdr x))))) + + + (define (identity x) x) (define call/cc call-with-current-continuation) @@ -91,4 +119,3 @@ (if (null? (cdddr r)) (cons (f (car l) (caar r) (caadr r) (car (caddr r))) (map f (cdr l) (cdar r) (cdadr r) (cdr (caddr r)))) (error 'unsupported (cons* "map 5:" f l r))) ))))) -