scm: Support map4.

* module/mes/base-0.mes (map): Remove.  Update callers.
* module/mes/base.mes (map): Support map4.

diff --git a/module/mes/base-0.mes b/module/mes/base-0.mes
index 871a86db62069d24079fbc62e5334c6fb6287e62..78a525fd76c1fde41a99ee62e8582961705eb53d 100644 (file)
--- a/module/mes/base-0.mes
+++ b/module/mes/base-0.mes
@@ -81,18 +81,9 @@
 
 (define else #t)
 
-(define (map f l . r)
-  (if (null? l) '()
-      (if (null? r) (cons (f (car l)) (map f (cdr l)))
-          (if (null? (cdr r))
-              (cons (f (car l) (caar r)) (map f (cdr l) (cdar r)))
-              (if (null? (cddr r))
-                  (cons (f (car l) (caar r) (caadr r)) (map f (cdr l) (cdar r) (cdadr r)))
-                  '*MAP-4-NOT-SUPPORTED)))))
-
 (define-macro (simple-let bindings . rest)
-  (cons (cons 'lambda (cons (map car bindings) rest))
-        (map cadr bindings)))
+  (cons (cons 'lambda (cons (map1 car bindings) rest))
+        (map1 cadr bindings)))
 
 (define-macro (let bindings . rest)
   (cons 'simple-let (cons bindings rest)))
@@ -137,7 +128,7 @@
 
 (define *mes-prefix* "module/")
 (define (module->file o)
-  (string-append (string-join (map symbol->string o) "/") ".mes"))
+  (string-append (string-join (map1 symbol->string o) "/") ".mes"))
 
 (define *modules* '(mes/base-0.mes))
 (define (mes-load-module-env module a)

diff --git a/module/mes/base.mes b/module/mes/base.mes
index d31938589ce930686dae2ca932a47927fd366bbf..3bb1e4e5f9ca0cead70dff5ee082b9575de2f5d4 100644 (file)
--- a/module/mes/base.mes
+++ b/module/mes/base.mes
@@ -80,3 +80,15 @@
         ((and (pair? p) (eq? (car p) 'lambda)))
         ((closure? p) #t)
         (#t #f)))
+
+(define (map f l . r)
+  (if (null? l) '()
+      (if (null? r) (cons (f (car l)) (map f (cdr l)))
+          (if (null? (cdr r))
+              (cons (f (car l) (caar r)) (map f (cdr l) (cdar r)))
+              (if (null? (cddr r))
+                  (cons (f (car l) (caar r) (caadr r)) (map f (cdr l) (cdar r) (cdadr 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))) )))))
+