scm: Add c????r.

* module/mes/base-0.mes (caar, cadr, cdar, cddr, map): Remove.  Update callers.
* module/mes/base.mes (): Remove.
* module/mes/base.mes (cadadr, cddadr, cdddar): New function.

diff --git a/module/mes/base-0.mes b/module/mes/base-0.mes
index 78a525fd76c1fde41a99ee62e8582961705eb53d..11359fc2dab1255441748bea863df76f5f286329 100644 (file)
--- 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 (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)
 (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))
 
 (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)))))
 
   (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)))))
 (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
                (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))
                                     (list (cons 'lambda (cons '() (car clauses)))))
                                 (list (cons 'lambda (cons '() (car clauses)))))
                             (if (pair? (cdr clauses))


@@ -81,6 +75,7 @@
 
 (define else #t)
 
 
 (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)))
 (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)))))))
 
           (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 (mes base))

+(mes-use-module (srfi srfi-0))

 (mes-use-module (mes quasiquote))
 (mes-use-module (mes let))
 (mes-use-module (mes scm))
 (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 3bb1e4e5f9ca0cead70dff5ee082b9575de2f5d4..1c2f67986635a4a14b21405026668ab5f2751ec4 100644 (file)
--- 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 (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 (caaar x) (car (car (car x))))
 (define (caadr x) (car (car (cdr x))))

+(define (cadar x) (car (cdr (car x))))

 (define (caddr x) (car (cdr (cdr x))))
 (define (caddr x) (car (cdr (cdr x))))

+
+(define (cdaar x) (cdr (car (car x))))

 (define (cdadr x) (cdr (car (cdr x))))
 (define (cdadr x) (cdr (car (cdr x))))

-(define (cadar x) (car (cdr (car x))))

 (define (cddar x) (cdr (cdr (car x))))
 (define (cdddr x) (cdr (cdr (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 (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)
 
 (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))) )))))
                   (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))) )))))

-