From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 22 Feb 1997 07:49:39 +0000 (+0000)
Subject: Add several new operations on vectors.  Eliminate unnecessary
X-Git-Tag: 20090517-FFI~5253
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=9d4dea660f2e0e6947416fafd93f3b880531396a;p=mit-scheme.git

Add several new operations on vectors.  Eliminate unnecessary
bindings.
---

diff --git a/v7/src/runtime/vector.scm b/v7/src/runtime/vector.scm
index 96a42cb36..46c84b7ff 100644
--- a/v7/src/runtime/vector.scm
+++ b/v7/src/runtime/vector.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: vector.scm,v 14.6 1995/07/27 21:33:27 adams Exp $
+$Id: vector.scm,v 14.7 1997/02/22 07:49:39 cph Exp $
 
-Copyright (c) 1988-1995 Massachusetts Institute of Technology
+Copyright (c) 1988-97 Massachusetts Institute of Technology
 
 This material was developed by the Scheme project at the Massachusetts
 Institute of Technology, Department of Electrical Engineering and
@@ -42,31 +42,40 @@ MIT in each case. |#
  list->vector vector subvector->list
  subvector-move-right! subvector-move-left! subvector-fill!)
 
+(define-integrable (guarantee-vector object procedure)
+  (if (not (vector? object))
+      (error:wrong-type-argument object "vector" procedure)))
+
+(define-integrable (guarantee-subvector vector start end procedure)
+  (guarantee-vector vector procedure)
+  (if (not (index-fixnum? start))
+      (error:wrong-type-argument start "valid vector index" procedure))
+  (if (not (index-fixnum? end))
+      (error:wrong-type-argument end "valid vector index" procedure))
+  (if (not (fix:<= start end))
+      (error:bad-range-argument start procedure))
+  (if (not (fix:<= end (vector-length vector)))
+      (error:bad-range-argument end procedure)))
+
 (define-integrable (vector? object)
   (object-type? (ucode-type vector) object))
 
 (define (make-vector size #!optional fill)
-  (guarantee-index/vector size 'make-vector)
-  (let ((fill (if (default-object? fill) default-vector-fill-value fill)))
-    (%make-vector size fill)))
-		
-
-(define-integrable default-vector-fill-value #F)
-
-(define-integrable (%make-vector size fill)
-  ((ucode-primitive vector-cons) size fill))
+  (if (not (index-fixnum? size))
+      (error:wrong-type-argument size "valid vector index" 'MAKE-VECTOR))
+  ((ucode-primitive vector-cons) size (if (default-object? fill) #f fill)))
 
 (define (vector->list vector)
-  (guarantee-vector vector 'vector->list)
+  (guarantee-vector vector 'VECTOR->LIST)
   (subvector->list vector 0 (vector-length vector)))
 
 (define (vector-fill! vector value)
-  (guarantee-vector vector 'vector-fill!)
+  (guarantee-vector vector 'VECTOR-FILL!)
   (subvector-fill! vector 0 (vector-length vector) value))
 
 (define (subvector vector start end)
-  ;; VECTOR, START and END checked by `-' and SUBVECTOR-MOVE-RIGHT!
-  (let ((result (make-vector (- end start) #F)))
+  (guarantee-subvector vector start end 'SUBVECTOR)
+  (let ((result (make-vector (fix:- end start))))
     (subvector-move-right! vector start end result 0)
     result))
 
@@ -74,28 +83,26 @@ MIT in each case. |#
   (subvector vector 0 end))
 
 (define (vector-tail vector start)
-  (guarantee-vector vector 'vector-tail)
+  (guarantee-vector vector 'VECTOR-TAIL)
   (subvector vector start (vector-length vector)))
 
 (define (vector-copy vector)
-  (guarantee-vector vector 'vector-copy)
+  (guarantee-vector vector 'VECTOR-COPY)
   (let ((length (vector-length vector)))
-    (let ((new-vector (%make-vector length #F)))
+    (let ((new-vector (make-vector length)))
       (subvector-move-right! vector 0 length new-vector 0)
       new-vector)))
-
-(define (%vector-append vectors)
+
+(define (vector-append . vectors)
   (let ((result
-	 (%make-vector
+	 (make-vector
 	  (let loop ((vectors vectors) (length 0))
 	    (if (null? vectors)
 		length
 		(begin
-		  (guarantee-vector (car vectors) 'vector-append)
+		  (guarantee-vector (car vectors) 'VECTOR-APPEND)
 		  (loop (cdr vectors)
-			(fix:+ (vector-length (car vectors)) length)))))
-	  #F)))
-
+			(fix:+ (vector-length (car vectors)) length))))))))
     (let loop ((vectors vectors) (index 0))
       (if (null? vectors)
 	  result
@@ -103,31 +110,28 @@ MIT in each case. |#
 	    (subvector-move-right! (car vectors) 0 size result index)
 	    (loop (cdr vectors) (fix:+ index size)))))))
 
-(define (vector-append . vectors)
-  (%vector-append vectors))
-
 (define (vector-grow vector length)
-  (guarantee-vector vector 'vector-grow)
-  (let ((new-vector (make-vector length default-vector-fill-value)))
+  (guarantee-vector vector 'VECTOR-GROW)
+  (let ((new-vector (make-vector length #f)))
     (subvector-move-right! vector 0 (vector-length vector) new-vector 0)
     new-vector))
 
 (define (make-initialized-vector length initialization)
   ;; LENGTH is checked by MAKE-VECTOR
-  (let ((vector (make-vector length #F)))
+  (let ((vector (make-vector length)))
     (let loop ((index 0))
       (if (fix:< index length)
 	  (begin
 	    (vector-set! vector index (initialization index))
 	    (loop (fix:+ index 1)))))
     vector))
-
+
 (define (vector-map vector procedure)
-  (guarantee-vector vector 'vector-map)
+  (guarantee-vector vector 'VECTOR-MAP)
   (let ((length (vector-length vector)))
-    (if (fix:zero? length)
+    (if (fix:= 0 length)
 	vector
-	(let ((result (%make-vector length #F)))
+	(let ((result (make-vector length)))
 	  (let loop ((index 0))
 	    (if (fix:< index length)
 		(begin
@@ -138,44 +142,56 @@ MIT in each case. |#
 	  result))))
 
 (define (for-each-vector-element vector procedure)
-  (guarantee-vector vector 'for-each-vector-element)
+  (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)))))))
-
+
 (define (subvector-find-next-element vector start end item)
-  (guarantee-vector vector 'subvector-find-next-element)
-  (guarantee-index/vector start 'subvector-find-next-element)
-  (guarantee-vector-bound end vector 'subvector-find-next-element)
+  (guarantee-subvector vector start end 'SUBVECTOR-FIND-NEXT-ELEMENT)
   (let loop ((index start))
     (and (fix:< index end)
 	 (if (eqv? (vector-ref vector index) item)
 	     index
 	     (loop (fix:+ index 1))))))
 
+(define (subvector-find-next-element-not vector start end item)
+  (guarantee-subvector vector start end 'SUBVECTOR-FIND-NEXT-ELEMENT-NOT)
+  (let loop ((index start))
+    (and (fix:< index end)
+	 (if (eqv? (vector-ref vector index) item)
+	     (loop (fix:+ index 1))
+	     index))))
+
 (define (subvector-find-previous-element vector start end item)
-  (guarantee-vector vector 'subvector-find-previous-element)
-  (guarantee-index/vector start 'subvector-find-previous-element)
-  (guarantee-vector-bound end vector 'subvector-find-previous-element)
+  (guarantee-subvector vector start end 'SUBVECTOR-FIND-PREVIOUS-ELEMENT)
   (let loop ((index (fix:- end 1)))
     (and (fix:<= start index)
 	 (if (eqv? (vector-ref vector index) item)
 	     index
 	     (loop (fix:- index 1))))))
 
+(define (subvector-find-previous-element-not vector start end item)
+  (guarantee-subvector vector start end 'SUBVECTOR-FIND-PREVIOUS-ELEMENT-NOT)
+  (let loop ((index (fix:- end 1)))
+    (and (fix:<= start index)
+	 (if (eqv? (vector-ref vector index) item)
+	     (loop (fix:- index 1))
+	     index))))
+
 (define-integrable (vector-find-next-element vector item)
-  (guarantee-vector vector 'vector-find-next-element)
+  (guarantee-vector vector 'VECTOR-FIND-NEXT-ELEMENT)
   (subvector-find-next-element vector 0 (vector-length vector) item))
 
 (define-integrable (vector-find-previous-element vector item)
-  (guarantee-vector vector 'vector-find-previous-element)
+  (guarantee-vector vector 'VECTOR-FIND-PREVIOUS-ELEMENT)
   (subvector-find-previous-element vector 0 (vector-length vector) item))
 
 (define (vector-binary-search vector key<? unwrap-key key)
-  (guarantee-vector vector 'vector-binary-search)
+  (guarantee-vector vector 'VECTOR-BINARY-SEARCH)
   (let loop ((start 0) (end (vector-length vector)))
     (and (fix:< start end)
 	 (let ((midpoint (fix:quotient (fix:+ start end) 2)))
@@ -185,39 +201,42 @@ MIT in each case. |#
 		     ((key<? key* key) (loop (fix:+ midpoint 1) end))
 		     (else item))))))))
 
-(define-integrable (safe-vector-ref vector index)
-  (guarantee-vector vector 'safe-vector-ref)
-  (guarantee-vector-index index vector 'safe-vector-ref)
-  (vector-ref vector index))
-
-(define-integrable (vector-first vector) (safe-vector-ref vector 0))
-(define-integrable (vector-second vector) (safe-vector-ref vector 1))
-(define-integrable (vector-third vector) (safe-vector-ref vector 2))
-(define-integrable (vector-fourth vector) (safe-vector-ref vector 3))
-(define-integrable (vector-fifth vector) (safe-vector-ref vector 4))
-(define-integrable (vector-sixth vector) (safe-vector-ref vector 5))
-(define-integrable (vector-seventh vector) (safe-vector-ref vector 6))
-(define-integrable (vector-eighth vector) (safe-vector-ref vector 7))
+(let-syntax
+    ((iref
+      (macro (name index)
+	`(DEFINE-INTEGRABLE (,name VECTOR)
+	   (GUARANTEE-VECTOR VECTOR 'SAFE-VECTOR-REF)
+	   (VECTOR-REF VECTOR ,index)))))
+  (iref vector-first 0)
+  (iref vector-second 1)
+  (iref vector-third 2)
+  (iref vector-fourth 3)
+  (iref vector-fifth 4)
+  (iref vector-sixth 5)
+  (iref vector-seventh 6)
+  (iref vector-eighth 7))
 
-(define-integrable (guarantee-vector object procedure)
-  (if (not (vector? object))
-      (error:wrong-type-argument object "vector" procedure)))
+(define (vector-move! v1 v2)
+  (guarantee-vector v1 'VECTOR-MOVE!)
+  (subvector-move-left! v1 0 (vector-length v1) v2 0))
 
-(define-integrable (guarantee-index/vector object procedure)
-  (if (not (index-fixnum? object))
-      (guarantee-index/vector/fail object procedure)))
-
-(define (guarantee-index/vector/fail object procedure)
-  (error:wrong-type-argument object "valid vector index"
-			     procedure))
+(define (subvector-filled? vector start end element)
+  (guarantee-subvector vector start end 'SUBVECTOR-FILLED?)
+  (let loop ((index start))
+    (or (fix:= index end)
+	(and (eqv? (vector-ref v index) element)
+	     (loop (fix:+ index 1))))))
 
-(define-integrable (guarantee-vector-index object vector procedure)
-  (guarantee-index/vector object procedure)
-  (if (not (fix:< object (vector-length vector)))
-      (error:bad-range-argument object procedure)))
+(define (vector-filled? vector element)
+  (guarantee-subvector vector 'VECTOR-FILLED?)
+  (subvector-filled? vector 0 (vector-length vector) element))
 
-(define-integrable (guarantee-vector-bound object vector procedure)
-  (guarantee-index/vector object procedure)
-  (if (not (fix:<= object (vector-length vector)))
-      (error:bad-range-argument object procedure)))
+(define (subvector-uniform? vector start end)
+  (guarantee-subvector vector start end 'SUBVECTOR-UNIFORM?)
+  (if (fix:< start end)
+      (subvector-filled? vector (fix:+ start 1) end (vector-ref vector start))
+      #t))
 
+(define (vector-uniform? vector)
+  (guarantee-subvector vector 'VECTOR-UNIFORM?)
+  (subvector-uniform? vector 0 (vector-length vector)))
\ No newline at end of file