native implmentation of map

piclib/built-in.scm

@@ -39,13 +39,7 @@
   (define (caddr p) (car (cddr p)))
   (define (cdddr p) (cdr (cddr p)))
 
-  (define (map f list)
+  (export cadar caddr cdddr))
-    (if (null? list)
-        list
-        (cons (f (car list))
-              (map f (cdr list)))))
-
-  (export map cadar caddr cdddr))
 
 ;;; core syntaces
 (define-library (picrin core-syntax)
@@ -374,9 +368,6 @@
       s
       (fold f (f (car xs) s) (cdr xs))))
 
-;;; FIXME forward declaration
-(define map #f)
-
 ;;; 6.2. Numbers
 
 (define (zero? n)
@@ -757,22 +748,6 @@
 
 ;;; 6.10 control features
 
-(set! map
-      (lambda (f list . lists)
-        (define (single-map f list)
-          (if (null? list)
-              '()
-              (cons (f (car list))
-                    (map f (cdr list)))))
-        (define (multiple-map f lists)
-          (if (any null? lists)
-              '()
-              (cons (apply f (single-map car lists))
-                    (multiple-map f (single-map cdr lists)))))
-        (if (null? lists)
-            (single-map f list)
-            (multiple-map f (cons list lists)))))
-
 (define (for-each f list . lists)
   (define (single-for-each f list)
     (if (null? list)
@@ -828,7 +803,7 @@
 	       (map (lambda (v) (vector-ref v n)) vs))
 	(loop (+ n 1))))))
 
-(export map for-each
+(export for-each
         string-map string-for-each
         vector-map vector-for-each)
 

src/proc.c

@@ -85,21 +85,45 @@ static pic_value
 pic_proc_apply(pic_state *pic)
 {
   struct pic_proc *proc;
-  pic_value *args, v;
+  pic_value *args;
   size_t argc;
-  int i;
 
   pic_get_args(pic, "l*", &proc, &argc, &args);
 
   if (argc == 0) {
     pic_error(pic, "apply: wrong number of arguments");
   }
-  v = args[argc - 1];
-  for (i = argc - 2; i >= 0; --i) {
-    v = pic_cons(pic, args[i], v);
-  }
 
-  return pic_apply(pic, proc, v);
+  return pic_apply(pic, proc, pic_list_from_array(pic, argc, args));
+}
+
+static pic_value
+pic_proc_map(pic_state *pic)
+{
+  struct pic_proc *proc;
+  size_t argc;
+  pic_value *args;
+  int i;
+  pic_value cars, ret;
+
+  pic_get_args(pic, "l*", &proc, &argc, &args);
+
+  ret = pic_nil_value();
+  do {
+    cars = pic_nil_value();
+    for (i = argc - 1; i >= 0; --i) {
+      if (! pic_pair_p(args[i])) {
+        break;
+      }
+      cars = pic_cons(pic, pic_car(pic, args[i]), cars);
+      args[i] = pic_cdr(pic, args[i]);
+    }
+    if (i >= 0)
+      break;
+    ret = pic_cons(pic, pic_apply(pic, proc, cars), ret);
+  } while (1);
+
+  return pic_reverse(pic, ret);
 }
 
 void
@@ -107,4 +131,5 @@ pic_init_proc(pic_state *pic)
 {
   pic_defun(pic, "procedure?", pic_proc_proc_p);
   pic_defun(pic, "apply", pic_proc_apply);
+  pic_defun(pic, "map", pic_proc_map);
 }