From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 14 Jun 2005 18:17:38 +0000 (+0000)
Subject: Allow VECTOR-MAP to take multiple vector arguments.  Implement
X-Git-Tag: 20090517-FFI~1273
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=70d63a158730d3a94240a0960962564bc0898a77;p=mit-scheme.git

Allow VECTOR-MAP to take multiple vector arguments.  Implement
VECTOR-FOR-EACH similarly.
---

diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg
index 4a4b89a01..6d6d930a3 100644
--- a/v7/src/runtime/runtime.pkg
+++ b/v7/src/runtime/runtime.pkg
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: runtime.pkg,v 14.556 2005/06/13 19:06:41 cph Exp $
+$Id: runtime.pkg,v 14.557 2005/06/14 18:17:34 cph Exp $
 
 Copyright 1988,1989,1990,1991,1992,1993 Massachusetts Institute of Technology
 Copyright 1994,1995,1996,1997,1998,1999 Massachusetts Institute of Technology
@@ -603,6 +603,7 @@ USA.
 	  vector-find-next-element
 	  vector-find-previous-element
 	  vector-first
+	  vector-for-each
 	  vector-fourth
 	  vector-grow
 	  vector-head
diff --git a/v7/src/runtime/vector.scm b/v7/src/runtime/vector.scm
index 591072cbd..2cae8833d 100644
--- a/v7/src/runtime/vector.scm
+++ b/v7/src/runtime/vector.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Id: vector.scm,v 14.23 2003/02/14 18:28:34 cph Exp $
+$Id: vector.scm,v 14.24 2005/06/14 18:17:38 cph Exp $
 
 Copyright (c) 1988-2002 Massachusetts Institute of Technology
 
@@ -118,33 +118,40 @@ USA.
 	    (loop (fix:+ index 1)))))
     vector))
 
-(define (vector-map procedure vector)
-  (if (vector? procedure)
-      ;; KLUDGE: accept arguments in old order.
-      (vector-map vector procedure)
-      (begin
-	(guarantee-vector vector 'VECTOR-MAP)
-	(let ((length (vector-length vector)))
-	  (if (fix:= 0 length)
-	      vector
-	      (let ((result (make-vector length)))
-		(let loop ((index 0))
-		  (if (fix:< index length)
-		      (begin
-			(vector-set! result
-				     index
-				     (procedure (vector-ref vector index)))
-			(loop (fix:+ index 1)))))
-		result))))))
+(define (vector-map procedure vector . vectors)
+  (guarantee-vector vector 'VECTOR-MAP)
+  (for-each (lambda (v) (guarantee-vector v 'VECTOR-MAP)) vectors)
+  (let ((n (vector-length vector)))
+    (for-each (lambda (v)
+		(if (not (fix:= (vector-length v) n))
+		    (error:bad-range-argument v 'VECTOR-MAP)))
+	      vectors)
+    (let ((result (make-vector n)))
+      (do ((i 0 (fix:+ i 1)))
+	  ((not (fix:< i n)))
+	(vector-set! result
+		     i
+		     (apply procedure
+			    (vector-ref vector i)
+			    (map (lambda (v) (vector-ref v i)) vectors))))
+      result)))
+
+(define (vector-for-each procedure vector . vectors)
+  (guarantee-vector vector 'VECTOR-FOR-EACH)
+  (for-each (lambda (v) (guarantee-vector v 'VECTOR-FOR-EACH)) vectors)
+  (let ((n (vector-length vector)))
+    (for-each (lambda (v)
+		(if (not (fix:= (vector-length v) n))
+		    (error:bad-range-argument v 'VECTOR-FOR-EACH)))
+	      vectors)
+    (do ((i 0 (fix:+ i 1)))
+	((not (fix:< i n)) unspecific)
+      (apply procedure
+	     (vector-ref vector i)
+	     (map (lambda (v) (vector-ref v i)) vectors)))))
 
 (define (for-each-vector-element vector procedure)
-  (guarantee-vector vector 'FOR-EACH-VECTOR-ELEMENT)
-  (let ((length (vector-length vector)))
-    (let loop ((index 0))
-      (if (fix:< index length)
-	  (begin
-	    (procedure (vector-ref vector index))
-	    (loop (fix:+ index 1)))))))
+  (vector-for-each procedure vector))
 
 (define (vector-of-type? vector predicate)
   (and (vector? vector)