native implementatino of for-each

piclib/built-in.scm

@@ -748,23 +748,6 @@
 
 ;;; 6.10 control features
 
-(define (for-each f list . lists)
-  (define (single-for-each f list)
-    (if (null? list)
-	#f
-	(begin
-	  (f (car list))
-	  (single-for-each f (cdr list)))))
-  (define (multiple-for-each f lists)
-    (if (any null? lists)
-	#f
-	(begin
-	  (apply f (map car lists))
-	  (multiple-for-each f (map cdr lists)))))
-  (if (null? lists)
-      (single-for-each f list)
-      (multiple-for-each f (cons list lists))))
-
 (define (string-map f v . vs)
   (let* ((len (fold min (string-length v) (map string-length vs)))
 	 (vec (make-string len)))
@@ -803,8 +786,7 @@
 	       (map (lambda (v) (vector-ref v n)) vs))
 	(loop (+ n 1))))))
 
-(export for-each
-        string-map string-for-each
+(export string-map string-for-each
         vector-map vector-for-each)
 
 ;;; 6.13. Input and output

src/proc.c

@@ -126,10 +126,39 @@ pic_proc_map(pic_state *pic)
   return pic_reverse(pic, ret);
 }
 
+static pic_value
+pic_proc_for_each(pic_state *pic)
+{
+  struct pic_proc *proc;
+  size_t argc;
+  pic_value *args;
+  int i;
+  pic_value cars;
+
+  pic_get_args(pic, "l*", &proc, &argc, &args);
+
+  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;
+    pic_apply(pic, proc, cars);
+  } while (1);
+
+  return pic_none_value();
+}
+
 void
 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);
+  pic_defun(pic, "for-each", pic_proc_for_each);
 }