From 70d63a158730d3a94240a0960962564bc0898a77 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 14 Jun 2005 18:17:38 +0000
Subject: [PATCH] Allow VECTOR-MAP to take multiple vector arguments.
Implement VECTOR-FOR-EACH similarly.
---
v7/src/runtime/runtime.pkg | 3 +-
v7/src/runtime/vector.scm | 59 +++++++++++++++++++++-----------------
2 files changed, 35 insertions(+), 27 deletions(-)
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)
--
2.25.1