[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH] Implement SRFI-43 Vector Library
|
From: |
Mark H Weaver |
|
Subject: |
[PATCH] Implement SRFI-43 Vector Library |
|
Date: |
Tue, 28 Jan 2014 02:05:34 -0500 |
Hello all,
I've written a new implementation of the SRFI-43 vector library,
optimized specifically for Guile.
The SRFI-43 reference implementation is well written for one limited to
R5RS, but unfortunately in Guile it would not be very efficient because
the rest lists would have to be consed. In this implementation, I use
'case-lambda' for most of the procedures, with optimized cases for up to
2 seed/vector arguments.
The optimized cases required a comprehensive test suite to verify all of
the code paths, and I made sure to do so carefully. The test suite was
based on work by Shiro Kawai (which he placed in the public domain) but
I added a large number of additional tests, and converted it to use
Guile's (test-suite lib).
Full documentation and docstrings are also included. I chose to include
procedure signatures in the docstrings, which is a bit unusual for Guile
docstrings, but without them I find them much less comprehensible. Note
that although (texinfo reflection) renders procedure signatures nicely
in most cases, it does not handle 'case-lambda' properly, and even if it
did the result would be much less concise than the ones I included.
I'd like to push this to stable-2.0 in time for the 2.0.10 release.
Comments and suggestions welcome.
Mark
>From 451ea8b6a5abdc37f481ceaf481127e35d6bc381 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <address@hidden>
Date: Mon, 27 Jan 2014 17:17:23 -0500
Subject: [PATCH] Implement SRFI-43 Vector Library.
* module/srfi/srfi-43.scm: New file.
* module/Makefile.am (SRFI_SOURCES): Add module/srfi/srfi-43.scm.
* test-suite/tests/srfi-43.test: New file.
* test-suite/Makefile.am (SCM_TESTS): Add test-suite/tests/srfi-43.test.
* doc/ref/srfi-modules.texi (SRFI-43, SRFI-43 Constructors)
(SRFI-43 Predicates, SRFI-43 Selectors, SRFI-43 Iteration)
(SRFI-43 Searching, SRFI-43 Mutators, SRFI-43 Conversion): New nodes.
---
doc/ref/srfi-modules.texi | 407 ++++++++++++
module/Makefile.am | 1 +
module/srfi/srfi-43.scm | 1082 ++++++++++++++++++++++++++++++++
test-suite/Makefile.am | 1 +
test-suite/tests/srfi-43.test | 1375 +++++++++++++++++++++++++++++++++++++++++
5 files changed, 2866 insertions(+), 0 deletions(-)
create mode 100644 module/srfi/srfi-43.scm
create mode 100644 test-suite/tests/srfi-43.test
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 8845c85..d445815 100644
--- a/doc/ref/srfi-modules.texi
+++ b/doc/ref/srfi-modules.texi
@@ -47,6 +47,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-39:: Parameter objects
* SRFI-41:: Streams.
* SRFI-42:: Eager comprehensions
+* SRFI-43:: Vector Library.
* SRFI-45:: Primitives for expressing iterative lazy
algorithms
* SRFI-46:: Basic syntax-rules Extensions.
* SRFI-55:: Requiring Features.
@@ -4511,6 +4512,412 @@ the input @var{stream}s is finite, or is infinite if
all the input
See @uref{http://srfi.schemers.org/srfi-42/srfi-42.html, the
specification of SRFI-42}.
address@hidden SRFI-43
address@hidden SRFI-43 - Vector Library
address@hidden SRFI-43
+
+This subsection is based on the
address@hidden://srfi.schemers.org/srfi-43/srfi-43.html, specification of
+SRFI-43} by Taylor Campbell.
+
address@hidden The copyright notice and license text of the SRFI-43
specification is
address@hidden reproduced below:
+
address@hidden Copyright (C) Taylor Campbell (2003). All Rights Reserved.
+
address@hidden Permission is hereby granted, free of charge, to any person
obtaining a
address@hidden copy of this software and associated documentation files (the
address@hidden "Software"), to deal in the Software without restriction,
including
address@hidden without limitation the rights to use, copy, modify, merge,
publish,
address@hidden distribute, sublicense, and/or sell copies of the Software, and
to
address@hidden permit persons to whom the Software is furnished to do so,
subject to
address@hidden the following conditions:
+
address@hidden The above copyright notice and this permission notice shall be
included
address@hidden in all copies or substantial portions of the Software.
+
address@hidden THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS
address@hidden OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
address@hidden MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
address@hidden NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
HOLDERS BE
address@hidden LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
ACTION
address@hidden OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION
address@hidden WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
address@hidden
+This SRFI implements a comprehensive library of vector operations,
+analogous to the SRFI-1 list library. SRFI-43 can be made available
+with:
+
address@hidden
+(use-modules (srfi srfi-43))
address@hidden example
+
address@hidden
+* SRFI-43 Constructors::
+* SRFI-43 Predicates::
+* SRFI-43 Selectors::
+* SRFI-43 Iteration::
+* SRFI-43 Searching::
+* SRFI-43 Mutators::
+* SRFI-43 Conversion::
address@hidden menu
+
address@hidden SRFI-43 Constructors
address@hidden SRFI-43 Constructors
+
address@hidden {Scheme Procedure} make-vector size [fill]
+Create and return a vector of size @var{size}, optionally filling it
+with @var{fill}. The default value of @var{fill} is unspecified.
+
address@hidden
+(make-vector 5 3) @result{} #(3 3 3 3 3)
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} vector x @dots{}
+Create and return a vector whose elements are @var{x} @enddots{}.
+
address@hidden
+(vector 0 1 2 3 4) @result{} #(0 1 2 3 4)
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-unfold f length initial-seed @dots{}
+The fundamental vector constructor. Create a vector whose length is
address@hidden and iterates across each index k from 0 up to
address@hidden - 1, applying @var{f} at each iteration to the current index
+and current seeds, in that order, to receive n + 1 values: first, the
+element to put in the kth slot of the new vector and n new seeds for
+the next iteration. It is an error for the number of seeds to vary
+between iterations.
+
address@hidden
+(vector-unfold (lambda (i x) (values x (- x 1)))
+ 10 0)
address@hidden #(0 -1 -2 -3 -4 -5 -6 -7 -8 -9)
+
+(vector-unfold values 10)
address@hidden #(0 1 2 3 4 5 6 7 8 9)
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-unfold-right f length initial-seed
@dots{}
+Like @code{vector-unfold}, but it uses @var{f} to generate elements from
+right-to-left, rather than left-to-right.
+
address@hidden
+(vector-unfold-right (lambda (i x) (values x (+ x 1)))
+ 10 0)
address@hidden #(9 8 7 6 5 4 3 2 1 0)
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-copy vec [start [end [fill]]]
+Allocate a new vector whose length is @var{end} - @var{start} and fills
+it with elements from vec, taking elements from vec starting at index
address@hidden and stopping at index @var{end}. @var{start} defaults to 0
+and @var{end} defaults to the value of @code{(vector-length vec)}. If
address@hidden extends beyond the length of @var{vec}, the slots in the new
+vector that obviously cannot be filled by elements from @var{vec} are
+filled with @var{fill}, whose default value is unspecified.
+
address@hidden
+(vector-copy '#(a b c d e f g h i))
address@hidden #(a b c d e f g h i)
+
+(vector-copy '#(a b c d e f g h i) 6)
address@hidden #(g h i)
+
+(vector-copy '#(a b c d e f g h i) 3 6)
address@hidden #(d e f)
+
+(vector-copy '#(a b c d e f g h i) 6 12 'x)
address@hidden #(g h i x x x)
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-reverse-copy vec [start [end]]
+Like @code{vector-copy}, but it copies the elements in the reverse order
+from @var{vec}.
+
address@hidden
+(vector-reverse-copy '#(5 4 3 2 1 0) 1 5)
address@hidden #(1 2 3 4)
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-append vec @dots{}
+Return a newly allocated vector that contains all elements in order from
+the subsequent locations in @var{vec} @enddots{}.
+
address@hidden
+(vector-append '#(a) '#(b c d))
address@hidden #(a b c d)
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-concatenate list-of-vectors
+Append each vector in @var{list-of-vectors}. Equivalent to
address@hidden(apply vector-append list-of-vectors)}.
+
address@hidden
+(vector-concatenate '(#(a b) #(c d)))
address@hidden #(a b c d)
address@hidden example
address@hidden deffn
+
address@hidden SRFI-43 Predicates
address@hidden SRFI-43 Predicates
+
address@hidden {Scheme Procedure} vector? obj
+Return true if @var{obj} is a vector, else return false.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-empty? vec
+Return true if @var{vec} is empty, i.e. its length is 0, else return
+false.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector= elt=? vec @dots{}
+Return true if the vectors @var{vec} @dots{} have equal lengths and
+equal elements according to @var{elt=?}. @var{elt=?} is always applied
+to two arguments. Element comparison must be consistent with @code{eq?}
+in the following sense: if @code{(eq? a b)} returns true, then
address@hidden(elt=? a b)} must also return true. The order in which
+comparisons are performed is unspecified.
address@hidden deffn
+
address@hidden SRFI-43 Selectors
address@hidden SRFI-43 Selectors
+
address@hidden {Scheme Procedure} vector-ref vec i
+Return the value that the location in @var{vec} at @var{i} is mapped to
+in the store. Indexing is based on zero.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-length vec
+Returns the length of @var{vec}.
address@hidden deffn
+
address@hidden SRFI-43 Iteration
address@hidden SRFI-43 Iteration
+
address@hidden {Scheme Procedure} vector-fold kons knil vec1 vec2 @dots{}
+The fundamental vector iterator. @var{kons} is iterated over each index
+in all of the vectors, stopping at the end of the shortest; @var{kons}
+is applied as
address@hidden
+(kons i state (vector-ref vec1 i) (vector-ref vec2 i) ...)
address@hidden smalllisp
+where @var{state} is the current state value, and @var{i} is the current
+index. The current state value begins with @var{knil}, and becomes
+whatever @var{kons} returned at the respective iteration. The iteration
+is strictly left-to-right.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-fold-right kons knil vec1 vec2 @dots{}
+Similar to @code{vector-fold}, but it iterates right-to-left instead of
+left-to-right.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-map f vec1 vec2 @dots{}
+Return a new vector of the shortest size of the vector arguments. Each
+element at index i of the new vector is mapped from the old vectors by
address@hidden
+(f i (vector-ref vec1 i) (vector-ref vec2 i) ...)}
address@hidden smalllisp
+The dynamic order of application of @var{f} is unspecified.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-map! f vec1 vec2 @dots{}
+Similar to @code{vector-map}, but rather than mapping the new elements
+into a new vector, the new mapped elements are destructively inserted
+into @var{vec1}. The dynamic order of application of @var{f} is
+unspecified.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-for-each f vec1 vec2 @dots{}
+Call @code{(f i (vector-ref vec1 i) (vector-ref vec2 i) ...)} for each
+index i less than the length of the shortest vector passed. The
+iteration is strictly left-to-right.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-count pred? vec1 vec2 @dots{}
+Count the number of parallel elements in the vectors that satisfy
address@hidden, which is applied, for each index i less than the length of
+the smallest vector, to i and each parallel element in the vectors at
+that index, in order.
+
address@hidden
+(vector-count (lambda (i elt) (even? elt))
+ '#(3 1 4 1 5 9 2 5 6))
address@hidden 3
+(vector-count (lambda (i x y) (< x y))
+ '#(1 3 6 9) '#(2 4 6 8 10 12))
address@hidden 2
address@hidden example
address@hidden deffn
+
address@hidden SRFI-43 Searching
address@hidden SRFI-43 Searching
+
address@hidden {Scheme Procedure} vector-index pred? vec1 vec2 @dots{}
+Find and return the index of the first elements in @var{vec1} @var{vec2}
address@hidden that satisfy @var{pred?}. If no matching element is found by
+the end of the shortest vector, return @code{#f}.
+
address@hidden
+(vector-index even? '#(3 1 4 1 5 9))
address@hidden 2
+(vector-index < '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2))
address@hidden 1
+(vector-index = '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2))
address@hidden #f
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-index-right pred? vec1 vec2 @dots{}
+Like @code{vector-index}, but it searches right-to-left, rather than
+left-to-right. Note that the SRFI 43 specification requires that all
+the vectors must have the same length, but both the SRFI 43 reference
+implementation and Guile's implementation allow vectors with unequal
+lengths, and start searching from the last index of the shortest vector.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-skip pred? vec1 vec2 @dots{}
+Find and return the index of the first elements in @var{vec1} @var{vec2}
address@hidden that do not satisfy @var{pred?}. If no matching element is
+found by the end of the shortest vector, return @code{#f}. Equivalent
+to @code{vector-index} but with the predicate inverted.
+
address@hidden
+(vector-skip number? '#(1 2 a b 3 4 c d)) @result{} 2
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-skip-right pred? vec1 vec2 @dots{}
+Like @code{vector-skip}, but it searches for a non-matching element
+right-to-left, rather than left-to-right. Note that the SRFI 43
+specification requires that all the vectors must have the same length,
+but both the SRFI 43 reference implementation and Guile's implementation
+allow vectors with unequal lengths, and start searching from the last
+index of the shortest vector.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-binary-search vec value cmp
+Find and return an index of @var{vec} between @var{start} and @var{end}
+whose value is @var{value} using a binary search. If no matching
+element is found, return @code{#f}. The default @var{start} is 0 and
+the default @var{end} is the length of @var{vec}. @var{cmp} must be a
+procedure of two arguments such that @code{(cmp a b)} returns a negative
+integer if @math{a < b}, a positive integer if @math{a > b}, or zero if
address@hidden = b}. The elements of @var{vec} must be sorted in
+non-decreasing order according to @var{cmp}.
+
address@hidden
+(define (char-cmp c1 c2)
+ (cond ((char<? c1 c2) -1)
+ ((char>? c1 c2) 1)
+ (else 0)))
+
+(vector-binary-search '#(#\a #\b #\c #\d #\e #\f #\g #\h)
+ #\g
+ char-cmp)
address@hidden 6
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-any pred? vec1 vec2 @dots{}
+Find the first parallel set of elements from @var{vec1} @var{vec2}
address@hidden for which @var{pred?} returns a true value. If such a parallel
+set of elements exists, @code{vector-any} returns the value that
address@hidden returned for that set of elements. The iteration is
+strictly left-to-right.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-every pred? vec1 vec2 @dots{}
+If, for every index i between 0 and the length of the shortest vector
+argument, the set of elements @code{(vector-ref vec1 i)}
address@hidden(vector-ref vec2 i)} @dots{} satisfies @var{pred?},
address@hidden returns the value that @var{pred?} returned for the
+last set of elements, at the last index of the shortest vector.
+Otherwise it returns @code{#f}. The iteration is strictly
+left-to-right.
address@hidden deffn
+
address@hidden SRFI-43 Mutators
address@hidden SRFI-43 Mutators
+
address@hidden {Scheme Procedure} vector-set! vec i value
+Assign the contents of the location at @var{i} in @var{vec} to
address@hidden
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-swap! vec i j
+Swap the values of the locations in @var{vec} at @var{i} and @var{j}.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-fill! vec fill [start [end]]
+Assign the value of every location in @var{vec} between @var{start} and
address@hidden to @var{fill}. @var{start} defaults to 0 and @var{end}
+defaults to the length of @var{vec}.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-reverse! vec [start [end]]
+Destructively reverse the contents of @var{vec} between @var{start} and
address@hidden @var{start} defaults to 0 and @var{end} defaults to the
+length of @var{vec}.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-copy! target tstart source [sstart
[send]]
+Copy a block of elements from @var{source} to @var{target}, both of
+which must be vectors, starting in @var{target} at @var{tstart} and
+starting in @var{source} at @var{sstart}, ending when (@var{send} -
address@hidden) elements have been copied. It is an error for
address@hidden to have a length less than (@var{tstart} + @var{send} -
address@hidden). @var{sstart} defaults to 0 and @var{send} defaults to
+the length of @var{source}.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-reverse-copy! target tstart source
[sstart [send]]
+Like @code{vector-copy!}, but this copies the elements in the reverse
+order. It is an error if @var{target} and @var{source} are identical
+vectors and the @var{target} and @var{source} ranges overlap; however,
+if @var{tstart} = @var{sstart}, @code{vector-reverse-copy!} behaves as
address@hidden(vector-reverse! target tstart send)} would.
address@hidden deffn
+
address@hidden SRFI-43 Conversion
address@hidden SRFI-43 Conversion
+
address@hidden {Scheme Procedure} vector->list vec [start [end]]
+Return a newly allocated list containing the elements in @var{vec}
+between @var{start} and @var{end}. @var{start} defaults to 0 and
address@hidden defaults to the length of @var{vec}.
address@hidden deffn
+
address@hidden {Scheme Procedure} reverse-vector->list vec [start [end]]
+Like @code{vector->list}, but the resulting list contains the elements
+in reverse between the specified range.
address@hidden deffn
+
address@hidden {Scheme Procedure} list->vector proper-list [start [end]]
+Return a newly allocated vector of the elements from @var{proper-list}
+with indices between @var{start} and @var{end}. @var{start} defaults to
+0 and @var{end} defaults to the length of @var{proper-list}. Note that
+SRFI 43 does not document the @var{start} and @var{end} arguments, but
+both its reference implementation and Guile's implementation support
+them.
address@hidden deffn
+
address@hidden {Scheme Procedure} reverse-list->vector proper-list [start [end]]
+Like @code{list->vector}, but the resulting list contains specified
+range of elements of @var{proper-list} in reverse order. Note that SRFI
+43 does not document the @var{start} and @var{end} arguments, but both
+its reference implementation and Guile's implementation support them.
address@hidden deffn
+
@node SRFI-45
@subsection SRFI-45 - Primitives for Expressing Iterative Lazy Algorithms
@cindex SRFI-45
diff --git a/module/Makefile.am b/module/Makefile.am
index 47b9c2c..3daa9e6 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -289,6 +289,7 @@ SRFI_SOURCES = \
srfi/srfi-38.scm \
srfi/srfi-41.scm \
srfi/srfi-42.scm \
+ srfi/srfi-43.scm \
srfi/srfi-39.scm \
srfi/srfi-45.scm \
srfi/srfi-60.scm \
diff --git a/module/srfi/srfi-43.scm b/module/srfi/srfi-43.scm
new file mode 100644
index 0000000..4eff156
--- /dev/null
+++ b/module/srfi/srfi-43.scm
@@ -0,0 +1,1082 @@
+;;; srfi-43.scm -- SRFI 43 Vector library
+
+;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;
+;; This library is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU Lesser General Public
+;; License as published by the Free Software Foundation; either
+;; version 3 of the License, or (at your option) any later version.
+;;
+;; This library is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; Lesser General Public License for more details.
+;;
+;; You should have received a copy of the GNU Lesser General Public
+;; License along with this library; if not, write to the Free Software
+;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Author: Mark H Weaver <address@hidden>
+
+(define-module (srfi srfi-43)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-8)
+ #:re-export (make-vector vector vector? vector-ref vector-set!
+ vector-length)
+ #:replace (vector-copy vector-fill! list->vector vector->list)
+ #:export (vector-empty? vector= vector-unfold vector-unfold-right
+ vector-reverse-copy
+ vector-append vector-concatenate
+ vector-fold vector-fold-right
+ vector-map vector-map!
+ vector-for-each vector-count
+ vector-index vector-index-right
+ vector-skip vector-skip-right
+ vector-binary-search
+ vector-any vector-every
+ vector-swap! vector-reverse!
+ vector-copy! vector-reverse-copy!
+ reverse-vector->list
+ reverse-list->vector))
+
+(cond-expand-provide (current-module) '(srfi-43))
+
+(define (error-from who msg . args)
+ (apply error
+ (string-append (symbol->string who) ": " msg)
+ args))
+
+(define-syntax-rule (assert-nonneg-exact-integer k who)
+ (unless (and (exact-integer? k)
+ (not (negative? k)))
+ (error-from who "expected non-negative exact integer, got" k)))
+
+(define-syntax-rule (assert-procedure f who)
+ (unless (procedure? f)
+ (error-from who "expected procedure, got" f)))
+
+(define-syntax-rule (assert-vector v who)
+ (unless (vector? v)
+ (error-from who "expected vector, got" v)))
+
+(define-syntax-rule (assert-valid-index i len who)
+ (unless (and (exact-integer? i)
+ (<= 0 i)
+ (<= i len))
+ (error-from who "invalid index" i)))
+
+(define-syntax-rule (assert-valid-start start len who)
+ (unless (and (exact-integer? start)
+ (<= 0 start)
+ (<= start len))
+ (error-from who "invalid start index" start)))
+
+(define-syntax-rule (assert-valid-range start end len who)
+ (unless (and (exact-integer? start)
+ (exact-integer? end)
+ (<= 0 start)
+ (<= start end)
+ (<= end len))
+ (error-from who "invalid index range" start end)))
+
+(define-syntax-rule (assert-vectors vs who)
+ (let loop ((vs vs))
+ (unless (null? vs)
+ (assert-vector (car vs) who)
+ (loop (cdr vs)))))
+
+;; Return the length of the shortest vector in VS.
+;; VS must have at least one element.
+(define (min-length vs)
+ (let loop ((vs (cdr vs))
+ (result (vector-length (car vs))))
+ (if (null? vs)
+ result
+ (loop (cdr vs) (min result (vector-length (car vs)))))))
+
+;; Return a list of the Ith elements of the vectors in VS.
+(define (vectors-ref vs i)
+ (let loop ((vs vs) (xs '()))
+ (if (null? vs)
+ (reverse! xs)
+ (loop (cdr vs) (cons (vector-ref (car vs) i)
+ xs)))))
+
+(define vector-unfold
+ (case-lambda
+ "(vector-unfold f length initial-seed ...) -> vector
+
+The fundamental vector constructor. Create a vector whose length is
+LENGTH and iterates across each index k from 0 up to LENGTH - 1,
+applying F at each iteration to the current index and current seeds,
+in that order, to receive n + 1 values: first, the element to put in
+the kth slot of the new vector and n new seeds for the next iteration.
+It is an error for the number of seeds to vary between iterations."
+ ((f len)
+ (assert-procedure f 'vector-unfold)
+ (assert-nonneg-exact-integer len 'vector-unfold)
+ (let ((v (make-vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (vector-set! v i (f i))
+ (loop (+ i 1))))
+ v))
+ ((f len seed)
+ (assert-procedure f 'vector-unfold)
+ (assert-nonneg-exact-integer len 'vector-unfold)
+ (let ((v (make-vector len)))
+ (let loop ((i 0) (seed seed))
+ (unless (= i len)
+ (receive (x seed) (f i seed)
+ (vector-set! v i x)
+ (loop (+ i 1) seed))))
+ v))
+ ((f len seed1 seed2)
+ (assert-procedure f 'vector-unfold)
+ (assert-nonneg-exact-integer len 'vector-unfold)
+ (let ((v (make-vector len)))
+ (let loop ((i 0) (seed1 seed1) (seed2 seed2))
+ (unless (= i len)
+ (receive (x seed1 seed2) (f i seed1 seed2)
+ (vector-set! v i x)
+ (loop (+ i 1) seed1 seed2))))
+ v))
+ ((f len . seeds)
+ (assert-procedure f 'vector-unfold)
+ (assert-nonneg-exact-integer len 'vector-unfold)
+ (let ((v (make-vector len)))
+ (let loop ((i 0) (seeds seeds))
+ (unless (= i len)
+ (receive (x . seeds) (apply f i seeds)
+ (vector-set! v i x)
+ (loop (+ i 1) seeds))))
+ v))))
+
+(define vector-unfold-right
+ (case-lambda
+ "(vector-unfold-right f length initial-seed ...) -> vector
+
+The fundamental vector constructor. Create a vector whose length is
+LENGTH and iterates across each index k from LENGTH - 1 down to 0,
+applying F at each iteration to the current index and current seeds,
+in that order, to receive n + 1 values: first, the element to put in
+the kth slot of the new vector and n new seeds for the next iteration.
+It is an error for the number of seeds to vary between iterations."
+ ((f len)
+ (assert-procedure f 'vector-unfold-right)
+ (assert-nonneg-exact-integer len 'vector-unfold-right)
+ (let ((v (make-vector len)))
+ (let loop ((i (- len 1)))
+ (unless (negative? i)
+ (vector-set! v i (f i))
+ (loop (- i 1))))
+ v))
+ ((f len seed)
+ (assert-procedure f 'vector-unfold-right)
+ (assert-nonneg-exact-integer len 'vector-unfold-right)
+ (let ((v (make-vector len)))
+ (let loop ((i (- len 1)) (seed seed))
+ (unless (negative? i)
+ (receive (x seed) (f i seed)
+ (vector-set! v i x)
+ (loop (- i 1) seed))))
+ v))
+ ((f len seed1 seed2)
+ (assert-procedure f 'vector-unfold-right)
+ (assert-nonneg-exact-integer len 'vector-unfold-right)
+ (let ((v (make-vector len)))
+ (let loop ((i (- len 1)) (seed1 seed1) (seed2 seed2))
+ (unless (negative? i)
+ (receive (x seed1 seed2) (f i seed1 seed2)
+ (vector-set! v i x)
+ (loop (- i 1) seed1 seed2))))
+ v))
+ ((f len . seeds)
+ (assert-procedure f 'vector-unfold-right)
+ (assert-nonneg-exact-integer len 'vector-unfold-right)
+ (let ((v (make-vector len)))
+ (let loop ((i (- len 1)) (seeds seeds))
+ (unless (negative? i)
+ (receive (x . seeds) (apply f i seeds)
+ (vector-set! v i x)
+ (loop (- i 1) seeds))))
+ v))))
+
+(define guile-vector-copy (@ (guile) vector-copy))
+
+;; TODO: Enhance Guile core 'vector-copy' to do this.
+(define vector-copy
+ (case-lambda*
+ "(vector-copy vec [start [end [fill]]]) -> vector
+
+Allocate a new vector whose length is END - START and fills it with
+elements from vec, taking elements from vec starting at index START
+and stopping at index END. START defaults to 0 and END defaults to
+the value of (vector-length VEC). If END extends beyond the length of
+VEC, the slots in the new vector that obviously cannot be filled by
+elements from VEC are filled with FILL, whose default value is
+unspecified."
+ ((v) (guile-vector-copy v))
+ ((v start)
+ (assert-vector v 'vector-copy)
+ (let ((len (vector-length v)))
+ (assert-valid-start start len 'vector-copy)
+ (let ((result (make-vector (- len start))))
+ (vector-move-left! v start len result 0)
+ result)))
+ ((v start end #:optional (fill *unspecified*))
+ (assert-vector v 'vector-copy)
+ (let ((len (vector-length v)))
+ (unless (and (exact-integer? start)
+ (exact-integer? end)
+ (<= 0 start)
+ (<= start end))
+ (error-from 'vector-copy "invalid index range" start end))
+ (let ((result (make-vector (- end start) fill)))
+ (vector-move-left! v start (min end len) result 0)
+ result)))))
+
+(define vector-reverse-copy
+ (let ()
+ (define (%vector-reverse-copy vec start end)
+ (let* ((len (- end start))
+ (result (make-vector len)))
+ (let loop ((i 0) (j (- end 1)))
+ (unless (= i len)
+ (vector-set! result i (vector-ref vec j))
+ (loop (+ i 1) (- j 1))))
+ result))
+ (case-lambda
+ "(vector-reverse-copy vec [start [end]]) -> vector
+
+Allocate a new vector whose length is END - START and fills it with
+elements from vec, taking elements from vec in reverse order starting
+at index START and stopping at index END. START defaults to 0 and END
+defaults to the value of (vector-length VEC)."
+ ((vec)
+ (assert-vector vec 'vector-reverse-copy)
+ (%vector-reverse-copy vec 0 (vector-length vec)))
+ ((vec start)
+ (assert-vector vec 'vector-reverse-copy)
+ (let ((len (vector-length vec)))
+ (assert-valid-start start len 'vector-reverse-copy)
+ (%vector-reverse-copy vec start len)))
+ ((vec start end)
+ (assert-vector vec 'vector-reverse-copy)
+ (let ((len (vector-length vec)))
+ (assert-valid-range start end len 'vector-reverse-copy)
+ (%vector-reverse-copy vec start end))))))
+
+(define (%vector-concatenate vs)
+ (let* ((result-len (let loop ((vs vs) (len 0))
+ (if (null? vs)
+ len
+ (loop (cdr vs) (+ len (vector-length (car vs)))))))
+ (result (make-vector result-len)))
+ (let loop ((vs vs) (pos 0))
+ (unless (null? vs)
+ (let* ((v (car vs))
+ (len (vector-length v)))
+ (vector-move-left! v 0 len result pos)
+ (loop (cdr vs) (+ pos len)))))
+ result))
+
+(define vector-append
+ (case-lambda
+ "(vector-append vec ...) -> vector
+
+Return a newly allocated vector that contains all elements in order
+from the subsequent locations in VEC ..."
+ (() (vector))
+ ((v)
+ (assert-vector v 'vector-append)
+ (guile-vector-copy v))
+ ((v1 v2)
+ (assert-vector v1 'vector-append)
+ (assert-vector v2 'vector-append)
+ (let ((len1 (vector-length v1))
+ (len2 (vector-length v2)))
+ (let ((result (make-vector (+ len1 len2))))
+ (vector-move-left! v1 0 len1 result 0)
+ (vector-move-left! v2 0 len2 result len1)
+ result)))
+ (vs
+ (assert-vectors vs 'vector-append)
+ (%vector-concatenate vs))))
+
+(define (vector-concatenate vs)
+ "(vector-concatenate list-of-vectors) -> vector
+
+Append each vector in LIST-OF-VECTORS. Equivalent to:
+ (apply vector-append LIST-OF-VECTORS)"
+ (assert-vectors vs 'vector-append)
+ (%vector-concatenate vs))
+
+(define (vector-empty? vec)
+ "(vector-empty? vec) -> boolean
+
+Return true if VEC is empty, i.e. its length is 0, and false if not."
+ (assert-vector vec 'vector-empty?)
+ (zero? (vector-length vec)))
+
+(define vector=
+ (let ()
+ (define (all-of-length? len vs)
+ (or (null? vs)
+ (and (= len (vector-length (car vs)))
+ (all-of-length? len (cdr vs)))))
+ (define (=up-to? i elt=? v1 v2)
+ (or (negative? i)
+ (let ((x1 (vector-ref v1 i))
+ (x2 (vector-ref v2 i)))
+ (and (or (eq? x1 x2) (elt=? x1 x2))
+ (=up-to? (- i 1) elt=? v1 v2)))))
+ (case-lambda
+ "(vector= elt=? vec ...) -> boolean
+
+Return true if the vectors VEC ... have equal lengths and equal
+elements according to ELT=?. ELT=? is always applied to two
+arguments. Element comparison must be consistent with eq?, in the
+following sense: if (eq? a b) returns true, then (elt=? a b) must also
+return true. The order in which comparisons are performed is
+unspecified."
+ ((elt=?)
+ (assert-procedure elt=? 'vector=)
+ #t)
+ ((elt=? v)
+ (assert-procedure elt=? 'vector=)
+ (assert-vector v 'vector=)
+ #t)
+ ((elt=? v1 v2)
+ (assert-procedure elt=? 'vector=)
+ (assert-vector v1 'vector=)
+ (assert-vector v2 'vector=)
+ (let ((len (vector-length v1)))
+ (and (= len (vector-length v2))
+ (=up-to? (- len 1) elt=? v1 v2))))
+ ((elt=? v1 . vs)
+ (assert-procedure elt=? 'vector=)
+ (assert-vector v1 'vector=)
+ (assert-vectors vs 'vector=)
+ (let ((len (vector-length v1)))
+ (and (all-of-length? len vs)
+ (let loop ((vs vs))
+ (or (null? vs)
+ (and (=up-to? (- len 1) elt=? v1 (car vs))
+ (loop (cdr vs)))))))))))
+
+(define vector-fold
+ (case-lambda
+ "(vector-fold kons knil vec1 vec2 ...) -> value
+
+The fundamental vector iterator. KONS is iterated over each index in
+all of the vectors, stopping at the end of the shortest; KONS is
+applied as (KONS i state (vector-ref VEC1 i) (vector-ref VEC2 i) ...)
+where STATE is the current state value, and I is the current index.
+The current state value begins with KNIL, and becomes whatever KONS
+returned at the respective iteration. The iteration is strictly
+left-to-right."
+ ((kcons knil v)
+ (assert-procedure kcons 'vector-fold)
+ (assert-vector v 'vector-fold)
+ (let ((len (vector-length v)))
+ (let loop ((i 0) (state knil))
+ (if (= i len)
+ state
+ (loop (+ i 1) (kcons i state (vector-ref v i)))))))
+ ((kcons knil v1 v2)
+ (assert-procedure kcons 'vector-fold)
+ (assert-vector v1 'vector-fold)
+ (assert-vector v2 'vector-fold)
+ (let ((len (min (vector-length v1) (vector-length v2))))
+ (let loop ((i 0) (state knil))
+ (if (= i len)
+ state
+ (loop (+ i 1)
+ (kcons i state (vector-ref v1 i) (vector-ref v2 i)))))))
+ ((kcons knil . vs)
+ (assert-procedure kcons 'vector-fold)
+ (assert-vectors vs 'vector-fold)
+ (let ((len (min-length vs)))
+ (let loop ((i 0) (state knil))
+ (if (= i len)
+ state
+ (loop (+ i 1) (apply kcons i state (vectors-ref vs i)))))))))
+
+(define vector-fold-right
+ (case-lambda
+ "(vector-fold-right kons knil vec1 vec2 ...) -> value
+
+The fundamental vector iterator. KONS is iterated over each index in
+all of the vectors, starting at the end of the shortest; KONS is
+applied as (KONS i state (vector-ref VEC1 i) (vector-ref VEC2 i) ...)
+where STATE is the current state value, and I is the current index.
+The current state value begins with KNIL, and becomes whatever KONS
+returned at the respective iteration. The iteration is strictly
+right-to-left."
+ ((kcons knil v)
+ (assert-procedure kcons 'vector-fold-right)
+ (assert-vector v 'vector-fold-right)
+ (let ((len (vector-length v)))
+ (let loop ((i (- len 1)) (state knil))
+ (if (negative? i)
+ state
+ (loop (- i 1) (kcons i state (vector-ref v i)))))))
+ ((kcons knil v1 v2)
+ (assert-procedure kcons 'vector-fold-right)
+ (assert-vector v1 'vector-fold-right)
+ (assert-vector v2 'vector-fold-right)
+ (let ((len (min (vector-length v1) (vector-length v2))))
+ (let loop ((i (- len 1)) (state knil))
+ (if (negative? i)
+ state
+ (loop (- i 1)
+ (kcons i state (vector-ref v1 i) (vector-ref v2 i)))))))
+ ((kcons knil . vs)
+ (assert-procedure kcons 'vector-fold-right)
+ (assert-vectors vs 'vector-fold-right)
+ (let ((len (min-length vs)))
+ (let loop ((i (- len 1)) (state knil))
+ (if (negative? i)
+ state
+ (loop (- i 1) (apply kcons i state (vectors-ref vs i)))))))))
+
+(define vector-map
+ (case-lambda
+ "(vector-map f vec2 vec2 ...) -> vector
+
+Return a new vector of the shortest size of the vector arguments.
+Each element at index i of the new vector is mapped from the old
+vectors by (F i (vector-ref VEC1 i) (vector-ref VEC2 i) ...). The
+dynamic order of application of F is unspecified."
+ ((f v)
+ (assert-procedure f 'vector-map)
+ (assert-vector v 'vector-map)
+ (let* ((len (vector-length v))
+ (result (make-vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (vector-set! result i (f i (vector-ref v i)))
+ (loop (+ i 1))))
+ result))
+ ((f v1 v2)
+ (assert-procedure f 'vector-map)
+ (assert-vector v1 'vector-map)
+ (assert-vector v2 'vector-map)
+ (let* ((len (min (vector-length v1) (vector-length v2)))
+ (result (make-vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (vector-set! result i (f i (vector-ref v1 i) (vector-ref v2 i)))
+ (loop (+ i 1))))
+ result))
+ ((f . vs)
+ (assert-procedure f 'vector-map)
+ (assert-vectors vs 'vector-map)
+ (let* ((len (min-length vs))
+ (result (make-vector len)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (vector-set! result i (apply f i (vectors-ref vs i)))
+ (loop (+ i 1))))
+ result))))
+
+(define vector-map!
+ (case-lambda
+ "(vector-map! f vec2 vec2 ...) -> unspecified
+
+Similar to vector-map, but rather than mapping the new elements into a
+new vector, the new mapped elements are destructively inserted into
+VEC1. The dynamic order of application of F is unspecified."
+ ((f v)
+ (assert-procedure f 'vector-map!)
+ (assert-vector v 'vector-map!)
+ (let ((len (vector-length v)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (vector-set! v i (f i (vector-ref v i)))
+ (loop (+ i 1))))))
+ ((f v1 v2)
+ (assert-procedure f 'vector-map!)
+ (assert-vector v1 'vector-map!)
+ (assert-vector v2 'vector-map!)
+ (let ((len (min (vector-length v1) (vector-length v2))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (vector-set! v1 i (f i (vector-ref v1 i) (vector-ref v2 i)))
+ (loop (+ i 1))))))
+ ((f . vs)
+ (assert-procedure f 'vector-map!)
+ (assert-vectors vs 'vector-map!)
+ (let ((len (min-length vs))
+ (v1 (car vs)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (vector-set! v1 i (apply f i (vectors-ref vs i)))
+ (loop (+ i 1))))))))
+
+(define vector-for-each
+ (case-lambda
+ "(vector-for-each f vec1 vec2 ...) -> unspecified
+
+Call (F i VEC1[i] VEC2[i] ...) for each index i less than the length
+of the shortest vector passed. The iteration is strictly
+left-to-right."
+ ((f v)
+ (assert-procedure f 'vector-for-each)
+ (assert-vector v 'vector-for-each)
+ (let ((len (vector-length v)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f i (vector-ref v i))
+ (loop (+ i 1))))))
+ ((f v1 v2)
+ (assert-procedure f 'vector-for-each)
+ (assert-vector v1 'vector-for-each)
+ (assert-vector v2 'vector-for-each)
+ (let ((len (min (vector-length v1)
+ (vector-length v2))))
+ (let loop ((i 0))
+ (unless (= i len)
+ (f i (vector-ref v1 i) (vector-ref v2 i))
+ (loop (+ i 1))))))
+ ((f . vs)
+ (assert-procedure f 'vector-for-each)
+ (assert-vectors vs 'vector-for-each)
+ (let ((len (min-length vs)))
+ (let loop ((i 0))
+ (unless (= i len)
+ (apply f i (vectors-ref vs i))
+ (loop (+ i 1))))))))
+
+(define vector-count
+ (case-lambda
+ "(vector-count pred? vec1 vec2 ...) -> exact nonnegative integer
+
+Count the number of indices i for which (PRED? VEC1[i] VEC2[i] ...)
+returns true, where i is less than the length of the shortest vector
+passed."
+ ((pred? v)
+ (assert-procedure pred? 'vector-count)
+ (assert-vector v 'vector-count)
+ (let ((len (vector-length v)))
+ (let loop ((i 0) (count 0))
+ (cond ((= i len) count)
+ ((pred? i (vector-ref v i))
+ (loop (+ i 1) (+ count 1)))
+ (else
+ (loop (+ i 1) count))))))
+ ((pred? v1 v2)
+ (assert-procedure pred? 'vector-count)
+ (assert-vector v1 'vector-count)
+ (assert-vector v2 'vector-count)
+ (let ((len (min (vector-length v1)
+ (vector-length v2))))
+ (let loop ((i 0) (count 0))
+ (cond ((= i len) count)
+ ((pred? i (vector-ref v1 i) (vector-ref v2 i))
+ (loop (+ i 1) (+ count 1)))
+ (else
+ (loop (+ i 1) count))))))
+ ((pred? . vs)
+ (assert-procedure pred? 'vector-count)
+ (assert-vectors vs 'vector-count)
+ (let ((len (min-length vs)))
+ (let loop ((i 0) (count 0))
+ (cond ((= i len) count)
+ ((apply pred? i (vectors-ref vs i))
+ (loop (+ i 1) (+ count 1)))
+ (else
+ (loop (+ i 1) count))))))))
+
+(define vector-index
+ (case-lambda
+ "(vector-index pred? vec1 vec2 ...) -> exact nonnegative integer or #f
+
+Find and return the index of the first elements in VEC1 VEC2 ... that
+satisfy PRED?. If no matching element is found by the end of the
+shortest vector, return #f."
+ ((pred? v)
+ (assert-procedure pred? 'vector-index)
+ (assert-vector v 'vector-index)
+ (let ((len (vector-length v)))
+ (let loop ((i 0))
+ (and (< i len)
+ (if (pred? (vector-ref v i))
+ i
+ (loop (+ i 1)))))))
+ ((pred? v1 v2)
+ (assert-procedure pred? 'vector-index)
+ (assert-vector v1 'vector-index)
+ (assert-vector v2 'vector-index)
+ (let ((len (min (vector-length v1)
+ (vector-length v2))))
+ (let loop ((i 0))
+ (and (< i len)
+ (if (pred? (vector-ref v1 i)
+ (vector-ref v2 i))
+ i
+ (loop (+ i 1)))))))
+ ((pred? . vs)
+ (assert-procedure pred? 'vector-index)
+ (assert-vectors vs 'vector-index)
+ (let ((len (min-length vs)))
+ (let loop ((i 0))
+ (and (< i len)
+ (if (apply pred? (vectors-ref vs i))
+ i
+ (loop (+ i 1)))))))))
+
+(define vector-index-right
+ (case-lambda
+ "(vector-index-right pred? vec1 vec2 ...) -> exact nonnegative integer or
#f
+
+Find and return the index of the last elements in VEC1 VEC2 ... that
+satisfy PRED?, searching from right-to-left. If no matching element
+is found before the end of the shortest vector, return #f."
+ ((pred? v)
+ (assert-procedure pred? 'vector-index-right)
+ (assert-vector v 'vector-index-right)
+ (let ((len (vector-length v)))
+ (let loop ((i (- len 1)))
+ (and (>= i 0)
+ (if (pred? (vector-ref v i))
+ i
+ (loop (- i 1)))))))
+ ((pred? v1 v2)
+ (assert-procedure pred? 'vector-index-right)
+ (assert-vector v1 'vector-index-right)
+ (assert-vector v2 'vector-index-right)
+ (let ((len (min (vector-length v1)
+ (vector-length v2))))
+ (let loop ((i (- len 1)))
+ (and (>= i 0)
+ (if (pred? (vector-ref v1 i)
+ (vector-ref v2 i))
+ i
+ (loop (- i 1)))))))
+ ((pred? . vs)
+ (assert-procedure pred? 'vector-index-right)
+ (assert-vectors vs 'vector-index-right)
+ (let ((len (min-length vs)))
+ (let loop ((i (- len 1)))
+ (and (>= i 0)
+ (if (apply pred? (vectors-ref vs i))
+ i
+ (loop (- i 1)))))))))
+
+(define vector-skip
+ (case-lambda
+ "(vector-skip pred? vec1 vec2 ...) -> exact nonnegative integer or #f
+
+Find and return the index of the first elements in VEC1 VEC2 ... that
+do not satisfy PRED?. If no matching element is found by the end of
+the shortest vector, return #f."
+ ((pred? v)
+ (assert-procedure pred? 'vector-skip)
+ (assert-vector v 'vector-skip)
+ (let ((len (vector-length v)))
+ (let loop ((i 0))
+ (and (< i len)
+ (if (pred? (vector-ref v i))
+ (loop (+ i 1))
+ i)))))
+ ((pred? v1 v2)
+ (assert-procedure pred? 'vector-skip)
+ (assert-vector v1 'vector-skip)
+ (assert-vector v2 'vector-skip)
+ (let ((len (min (vector-length v1)
+ (vector-length v2))))
+ (let loop ((i 0))
+ (and (< i len)
+ (if (pred? (vector-ref v1 i)
+ (vector-ref v2 i))
+ (loop (+ i 1))
+ i)))))
+ ((pred? . vs)
+ (assert-procedure pred? 'vector-skip)
+ (assert-vectors vs 'vector-skip)
+ (let ((len (min-length vs)))
+ (let loop ((i 0))
+ (and (< i len)
+ (if (apply pred? (vectors-ref vs i))
+ (loop (+ i 1))
+ i)))))))
+
+(define vector-skip-right
+ (case-lambda
+ "(vector-skip-right pred? vec1 vec2 ...) -> exact nonnegative integer or #f
+
+Find and return the index of the last elements in VEC1 VEC2 ... that
+do not satisfy PRED?, searching from right-to-left. If no matching
+element is found before the end of the shortest vector, return #f."
+ ((pred? v)
+ (assert-procedure pred? 'vector-skip-right)
+ (assert-vector v 'vector-skip-right)
+ (let ((len (vector-length v)))
+ (let loop ((i (- len 1)))
+ (and (not (negative? i))
+ (if (pred? (vector-ref v i))
+ (loop (- i 1))
+ i)))))
+ ((pred? v1 v2)
+ (assert-procedure pred? 'vector-skip-right)
+ (assert-vector v1 'vector-skip-right)
+ (assert-vector v2 'vector-skip-right)
+ (let ((len (min (vector-length v1)
+ (vector-length v2))))
+ (let loop ((i (- len 1)))
+ (and (not (negative? i))
+ (if (pred? (vector-ref v1 i)
+ (vector-ref v2 i))
+ (loop (- i 1))
+ i)))))
+ ((pred? . vs)
+ (assert-procedure pred? 'vector-skip-right)
+ (assert-vectors vs 'vector-skip-right)
+ (let ((len (min-length vs)))
+ (let loop ((i (- len 1)))
+ (and (not (negative? i))
+ (if (apply pred? (vectors-ref vs i))
+ (loop (- i 1))
+ i)))))))
+
+(define vector-binary-search
+ (let ()
+ (define (%vector-binary-search vec value cmp start end)
+ (let loop ((lo start) (hi end))
+ (and (< lo hi)
+ (let* ((i (quotient (+ lo hi) 2))
+ (x (vector-ref vec i))
+ (c (cmp x value)))
+ (cond ((zero? c) i)
+ ((positive? c) (loop lo i))
+ ((negative? c) (loop (+ i 1) hi)))))))
+ (case-lambda
+ "(vector-binary-search vec value cmp [start [end]]) -> exact nonnegative
integer or #f
+
+Find and return an index of VEC between START and END whose value is
+VALUE using a binary search. If no matching element is found, return
+#f. The default START is 0 and the default END is the length of VEC.
+CMP must be a procedure of two arguments such that (CMP A B) returns
+a negative integer if A < B, a positive integer if A > B, or zero if
+A = B. The elements of VEC must be sorted in non-decreasing order
+according to CMP."
+ ((vec value cmp)
+ (assert-vector vec 'vector-binary-search)
+ (assert-procedure cmp 'vector-binary-search)
+ (%vector-binary-search vec value cmp 0 (vector-length vec)))
+
+ ((vec value cmp start)
+ (assert-vector vec 'vector-binary-search)
+ (let ((len (vector-length vec)))
+ (assert-valid-start start len 'vector-binary-search)
+ (%vector-binary-search vec value cmp start len)))
+
+ ((vec value cmp start end)
+ (assert-vector vec 'vector-binary-search)
+ (let ((len (vector-length vec)))
+ (assert-valid-range start end len 'vector-binary-search)
+ (%vector-binary-search vec value cmp start end))))))
+
+(define vector-any
+ (case-lambda
+ "(vector-any pred? vec1 vec2 ...) -> value or #f
+
+Find the first parallel set of elements from VEC1 VEC2 ... for which
+PRED? returns a true value. If such a parallel set of elements
+exists, vector-any returns the value that PRED? returned for that set
+of elements. The iteration is strictly left-to-right."
+ ((pred? v)
+ (assert-procedure pred? 'vector-any)
+ (assert-vector v 'vector-any)
+ (let ((len (vector-length v)))
+ (let loop ((i 0))
+ (and (< i len)
+ (or (pred? (vector-ref v i))
+ (loop (+ i 1)))))))
+ ((pred? v1 v2)
+ (assert-procedure pred? 'vector-any)
+ (assert-vector v1 'vector-any)
+ (assert-vector v2 'vector-any)
+ (let ((len (min (vector-length v1)
+ (vector-length v2))))
+ (let loop ((i 0))
+ (and (< i len)
+ (or (pred? (vector-ref v1 i)
+ (vector-ref v2 i))
+ (loop (+ i 1)))))))
+ ((pred? . vs)
+ (assert-procedure pred? 'vector-any)
+ (assert-vectors vs 'vector-any)
+ (let ((len (min-length vs)))
+ (let loop ((i 0))
+ (and (< i len)
+ (or (apply pred? (vectors-ref vs i))
+ (loop (+ i 1)))))))))
+
+(define vector-every
+ (case-lambda
+ "(vector-every pred? vec1 vec2 ...) -> value or #f
+
+If, for every index i less than the length of the shortest vector
+argument, the set of elements VEC1[i] VEC2[i] ... satisfies PRED?,
+vector-every returns the value that PRED? returned for the last set of
+elements, at the last index of the shortest vector. The iteration is
+strictly left-to-right."
+ ((pred? v)
+ (assert-procedure pred? 'vector-every)
+ (assert-vector v 'vector-every)
+ (let ((len (vector-length v)))
+ (or (zero? len)
+ (let loop ((i 0))
+ (let ((val (pred? (vector-ref v i)))
+ (next-i (+ i 1)))
+ (if (or (not val) (= next-i len))
+ val
+ (loop next-i)))))))
+ ((pred? v1 v2)
+ (assert-procedure pred? 'vector-every)
+ (assert-vector v1 'vector-every)
+ (assert-vector v2 'vector-every)
+ (let ((len (min (vector-length v1)
+ (vector-length v2))))
+ (or (zero? len)
+ (let loop ((i 0))
+ (let ((val (pred? (vector-ref v1 i)
+ (vector-ref v2 i)))
+ (next-i (+ i 1)))
+ (if (or (not val) (= next-i len))
+ val
+ (loop next-i)))))))
+ ((pred? . vs)
+ (assert-procedure pred? 'vector-every)
+ (assert-vectors vs 'vector-every)
+ (let ((len (min-length vs)))
+ (or (zero? len)
+ (let loop ((i 0))
+ (let ((val (apply pred? (vectors-ref vs i)))
+ (next-i (+ i 1)))
+ (if (or (not val) (= next-i len))
+ val
+ (loop next-i)))))))))
+
+(define (vector-swap! vec i j)
+ "(vector-swap! vec i j) -> unspecified
+
+Swap the values of the locations in VEC at I and J."
+ (assert-vector vec 'vector-swap!)
+ (let ((len (vector-length vec)))
+ (assert-valid-index i len 'vector-swap!)
+ (assert-valid-index j len 'vector-swap!)
+ (let ((tmp (vector-ref vec i)))
+ (vector-set! vec i (vector-ref vec j))
+ (vector-set! vec j tmp))))
+
+;; TODO: Enhance Guile core 'vector-fill!' to do this.
+(define vector-fill!
+ (let ()
+ (define guile-vector-fill!
+ (@ (guile) vector-fill!))
+ (define (%vector-fill! vec fill start end)
+ (let loop ((i start))
+ (when (< i end)
+ (vector-set! vec i fill)
+ (loop (+ i 1)))))
+ (case-lambda
+ "(vector-fill! vec fill [start [end]]) -> unspecified
+
+Assign the value of every location in VEC between START and END to
+FILL. START defaults to 0 and END defaults to the length of VEC."
+ ((vec fill)
+ (guile-vector-fill! vec fill))
+ ((vec fill start)
+ (assert-vector vec 'vector-fill!)
+ (let ((len (vector-length vec)))
+ (assert-valid-start start len 'vector-fill!)
+ (%vector-fill! vec fill start len)))
+ ((vec fill start end)
+ (assert-vector vec 'vector-fill!)
+ (let ((len (vector-length vec)))
+ (assert-valid-range start end len 'vector-fill!)
+ (%vector-fill! vec fill start end))))))
+
+(define (%vector-reverse! vec start end)
+ (let loop ((i start) (j (- end 1)))
+ (when (< i j)
+ (let ((tmp (vector-ref vec i)))
+ (vector-set! vec i (vector-ref vec j))
+ (vector-set! vec j tmp)
+ (loop (+ i 1) (- j 1))))))
+
+(define vector-reverse!
+ (case-lambda
+ "(vector-reverse! vec [start [end]]) -> unspecified
+
+Destructively reverse the contents of VEC between START and END.
+START defaults to 0 and END defaults to the length of VEC."
+ ((vec)
+ (assert-vector vec 'vector-reverse!)
+ (%vector-reverse! vec 0 (vector-length vec)))
+ ((vec start)
+ (assert-vector vec 'vector-reverse!)
+ (let ((len (vector-length vec)))
+ (assert-valid-start start len 'vector-reverse!)
+ (%vector-reverse! vec start len)))
+ ((vec start end)
+ (assert-vector vec 'vector-reverse!)
+ (let ((len (vector-length vec)))
+ (assert-valid-range start end len 'vector-reverse!)
+ (%vector-reverse! vec start end)))))
+
+(define-syntax-rule (define-vector-copier! copy! docstring inner-proc)
+ (define copy!
+ (let ((%copy! inner-proc))
+ (case-lambda
+ docstring
+ ((target tstart source)
+ (assert-vector target 'copy!)
+ (assert-vector source 'copy!)
+ (let ((tlen (vector-length target))
+ (slen (vector-length source)))
+ (assert-valid-start tstart tlen 'copy!)
+ (unless (>= tlen (+ tstart slen))
+ (error-from 'copy! "would write past end of target"))
+ (%copy! target tstart source 0 slen)))
+
+ ((target tstart source sstart)
+ (assert-vector target 'copy!)
+ (assert-vector source 'copy!)
+ (let ((tlen (vector-length target))
+ (slen (vector-length source)))
+ (assert-valid-start tstart tlen 'copy!)
+ (assert-valid-start sstart slen 'copy!)
+ (unless (>= tlen (+ tstart (- slen sstart)))
+ (error-from 'copy! "would write past end of target"))
+ (%copy! target tstart source sstart slen)))
+
+ ((target tstart source sstart send)
+ (assert-vector target 'copy!)
+ (assert-vector source 'copy!)
+ (let ((tlen (vector-length target))
+ (slen (vector-length source)))
+ (assert-valid-start tstart tlen 'copy!)
+ (assert-valid-range sstart send slen 'copy!)
+ (unless (>= tlen (+ tstart (- send sstart)))
+ (error-from 'copy! "would write past end of target"))
+ (%copy! target tstart source sstart send)))))))
+
+(define-vector-copier! vector-copy!
+ "(vector-copy! target tstart source [sstart [send]]) -> unspecified
+
+Copy a block of elements from SOURCE to TARGET, both of which must be
+vectors, starting in TARGET at TSTART and starting in SOURCE at
+SSTART, ending when SEND - SSTART elements have been copied. It is an
+error for TARGET to have a length less than TSTART + (SEND - SSTART).
+SSTART defaults to 0 and SEND defaults to the length of SOURCE."
+ (lambda (target tstart source sstart send)
+ (if (< tstart sstart)
+ (vector-move-left! source sstart send target tstart)
+ (vector-move-right! source sstart send target tstart))))
+
+(define-vector-copier! vector-reverse-copy!
+ "(vector-reverse-copy! target tstart source [sstart [send]]) -> unspecified
+
+Like vector-copy!, but copy the elements in the reverse order. It is
+an error if TARGET and SOURCE are identical vectors and the TARGET and
+SOURCE ranges overlap; however, if TSTART = SSTART,
+vector-reverse-copy! behaves as (vector-reverse! TARGET TSTART SEND)
+would."
+ (lambda (target tstart source sstart send)
+ (if (and (eq? target source) (= tstart sstart))
+ (%vector-reverse! target sstart send)
+ (let loop ((i tstart) (j (- send 1)))
+ (when (>= j sstart)
+ (vector-set! target i (vector-ref source j))
+ (loop (+ i 1) (- j 1)))))))
+
+(define vector->list
+ (let ()
+ (define (%vector->list vec start end)
+ (let loop ((i (- end 1))
+ (result '()))
+ (if (< i start)
+ result
+ (loop (- i 1) (cons (vector-ref vec i) result)))))
+ (case-lambda
+ "(vector->list vec [start [end]]) -> proper-list
+
+Return a newly allocated list containing the elements in VEC between
+START and END. START defaults to 0 and END defaults to the length of
+VEC."
+ ((vec)
+ (assert-vector vec 'vector->list)
+ (%vector->list vec 0 (vector-length vec)))
+ ((vec start)
+ (assert-vector vec 'vector->list)
+ (let ((len (vector-length vec)))
+ (assert-valid-start start len 'vector->list)
+ (%vector->list vec start len)))
+ ((vec start end)
+ (assert-vector vec 'vector->list)
+ (let ((len (vector-length vec)))
+ (assert-valid-range start end len 'vector->list)
+ (%vector->list vec start end))))))
+
+(define reverse-vector->list
+ (let ()
+ (define (%reverse-vector->list vec start end)
+ (let loop ((i start)
+ (result '()))
+ (if (>= i end)
+ result
+ (loop (+ i 1) (cons (vector-ref vec i) result)))))
+ (case-lambda
+ "(reverse-vector->list vec [start [end]]) -> proper-list
+
+Return a newly allocated list containing the elements in VEC between
+START and END in reverse order. START defaults to 0 and END defaults
+to the length of VEC."
+ ((vec)
+ (assert-vector vec 'reverse-vector->list)
+ (%reverse-vector->list vec 0 (vector-length vec)))
+ ((vec start)
+ (assert-vector vec 'reverse-vector->list)
+ (let ((len (vector-length vec)))
+ (assert-valid-start start len 'reverse-vector->list)
+ (%reverse-vector->list vec start len)))
+ ((vec start end)
+ (assert-vector vec 'reverse-vector->list)
+ (let ((len (vector-length vec)))
+ (assert-valid-range start end len 'reverse-vector->list)
+ (%reverse-vector->list vec start end))))))
+
+;; TODO: change to use 'case-lambda' and improve error checking.
+(define* (list->vector lst #:optional (start 0) (end (length lst)))
+ "(list->vector proper-list [start [end]]) -> vector
+
+Return a newly allocated vector of the elements from PROPER-LIST with
+indices between START and END. START defaults to 0 and END defaults
+to the length of PROPER-LIST."
+ (let* ((len (- end start))
+ (result (make-vector len)))
+ (let loop ((i 0) (lst (drop lst start)))
+ (if (= i len)
+ result
+ (begin (vector-set! result i (car lst))
+ (loop (+ i 1) (cdr lst)))))))
+
+;; TODO: change to use 'case-lambda' and improve error checking.
+(define* (reverse-list->vector lst #:optional (start 0) (end (length lst)))
+ "(reverse-list->vector proper-list [start [end]]) -> vector
+
+Return a newly allocated vector of the elements from PROPER-LIST with
+indices between START and END, in reverse order. START defaults to 0
+and END defaults to the length of PROPER-LIST."
+ (let* ((len (- end start))
+ (result (make-vector len)))
+ (let loop ((i (- len 1)) (lst (drop lst start)))
+ (if (negative? i)
+ result
+ (begin (vector-set! result i (car lst))
+ (loop (- i 1) (cdr lst)))))))
diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am
index 00f62fe..b148b54 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -133,6 +133,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-39.test \
tests/srfi-41.test \
tests/srfi-42.test \
+ tests/srfi-43.test \
tests/srfi-45.test \
tests/srfi-60.test \
tests/srfi-67.test \
diff --git a/test-suite/tests/srfi-43.test b/test-suite/tests/srfi-43.test
new file mode 100644
index 0000000..32ca68c
--- /dev/null
+++ b/test-suite/tests/srfi-43.test
@@ -0,0 +1,1375 @@
+;;;; srfi-43.test --- test suite for SRFI-43 Vector library -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;;
+;;; Originally written by Shiro Kawai and placed in the public domain
+;;; 10/5/2005.
+;;;
+;;; Many tests added, and adapted for Guile's (test-suite lib)
+;;; by Mark H Weaver <address@hidden>, Jan 2014.
+;;;
+
+(define-module (test-suite test-srfi-43)
+ #:use-module (srfi srfi-43)
+ #:use-module (test-suite lib))
+
+(define-syntax-rule (pass-if-error name body0 body ...)
+ (pass-if name
+ (catch #t
+ (lambda () body0 body ... #f)
+ (lambda (key . args) #t))))
+
+;;;
+;;; Constructors
+;;;
+
+;;
+;; make-vector
+;;
+
+(with-test-prefix "make-vector"
+
+ (pass-if-equal "simple, no init"
+ 5
+ (vector-length (make-vector 5)))
+
+ (pass-if-equal "empty"
+ '#()
+ (make-vector 0))
+
+ (pass-if-error "negative length"
+ (make-vector -4))
+
+ (pass-if-equal "simple with init"
+ '#(3 3 3 3 3)
+ (make-vector 5 3))
+
+ (pass-if-equal "empty with init"
+ '#()
+ (make-vector 0 3))
+
+ (pass-if-error "negative length"
+ (make-vector -1 3)))
+
+;;
+;; vector
+;;
+
+(with-test-prefix "vector"
+
+ (pass-if-equal "no args"
+ '#()
+ (vector))
+
+ (pass-if-equal "simple"
+ '#(1 2 3 4 5)
+ (vector 1 2 3 4 5)))
+
+;;
+;; vector-unfold
+;;
+
+(with-test-prefix "vector-unfold"
+
+ (pass-if-equal "no seeds"
+ '#(0 1 2 3 4 5 6 7 8 9)
+ (vector-unfold values 10))
+
+ (pass-if-equal "no seeds, zero len"
+ '#()
+ (vector-unfold values 0))
+
+ (pass-if-error "no seeds, negative len"
+ (vector-unfold values -1))
+
+ (pass-if-equal "1 seed"
+ '#(0 -1 -2 -3 -4 -5 -6 -7 -8 -9)
+ (vector-unfold (lambda (i x) (values x (- x 1)))
+ 10 0))
+
+ (pass-if-equal "1 seed, zero len"
+ '#()
+ (vector-unfold values 0 1))
+
+ (pass-if-error "1 seed, negative len"
+ (vector-unfold values -2 1))
+
+ (pass-if-equal "2 seeds"
+ '#((0 20) (-1 21) (-2 22) (-3 23) (-4 24)
+ (-5 25) (-6 26) (-7 27) (-8 28) (-9 29))
+ (vector-unfold (lambda (i x y) (values (list x y) (- x 1) (+ y 1)))
+ 10 0 20))
+
+ (pass-if-equal "2 seeds, zero len"
+ '#()
+ (vector-unfold values 0 1 2))
+
+ (pass-if-error "2 seeds, negative len"
+ (vector-unfold values -2 1 2))
+
+ (pass-if-equal "3 seeds"
+ '#((0 20 30) (-1 21 32) (-2 22 34) (-3 23 36) (-4 24 38)
+ (-5 25 40) (-6 26 42) (-7 27 44) (-8 28 46) (-9 29 48))
+ (vector-unfold (lambda (i x y z)
+ (values (list x y z) (- x 1) (+ y 1) (+ z 2)))
+ 10 0 20 30))
+
+ (pass-if-equal "3 seeds, zero len"
+ '#()
+ (vector-unfold values 0 1 2 3))
+
+ (pass-if-error "3 seeds, negative len"
+ (vector-unfold values -2 1 2 3)))
+
+;;
+;; vector-unfold-right
+;;
+
+(with-test-prefix "vector-unfold-right"
+
+ (pass-if-equal "no seeds, zero len"
+ '#()
+ (vector-unfold-right values 0))
+
+ (pass-if-error "no seeds, negative len"
+ (vector-unfold-right values -1))
+
+ (pass-if-equal "1 seed"
+ '#(9 8 7 6 5 4 3 2 1 0)
+ (vector-unfold-right (lambda (i x) (values x (+ x 1))) 10 0))
+
+ (pass-if-equal "1 seed, zero len"
+ '#()
+ (vector-unfold-right values 0 1))
+
+ (pass-if-error "1 seed, negative len"
+ (vector-unfold-right values -1 1))
+
+ (pass-if-equal "1 seed, reverse vector"
+ '#(e d c b a)
+ (let ((vector '#(a b c d e)))
+ (vector-unfold-right
+ (lambda (i x) (values (vector-ref vector x) (+ x 1)))
+ (vector-length vector)
+ 0)))
+
+ (pass-if-equal "2 seeds"
+ '#((0 20) (-1 21) (-2 22) (-3 23) (-4 24)
+ (-5 25) (-6 26) (-7 27) (-8 28) (-9 29))
+ (vector-unfold-right (lambda (i x y) (values (list x y) (+ x 1) (- y 1)))
+ 10 -9 29))
+
+ (pass-if-equal "2 seeds, zero len"
+ '#()
+ (vector-unfold-right values 0 1 2))
+
+ (pass-if-error "2 seeds, negative len"
+ (vector-unfold-right values -1 1 2))
+
+ (pass-if-equal "3 seeds"
+ '#((0 20 30) (-1 21 32) (-2 22 34) (-3 23 36) (-4 24 38)
+ (-5 25 40) (-6 26 42) (-7 27 44) (-8 28 46) (-9 29 48))
+ (vector-unfold-right (lambda (i x y z)
+ (values (list x y z) (+ x 1) (- y 1) (- z 2)))
+ 10 -9 29 48))
+
+ (pass-if-equal "3 seeds, zero len"
+ '#()
+ (vector-unfold-right values 0 1 2 3))
+
+ (pass-if-error "3 seeds, negative len"
+ (vector-unfold-right values -1 1 2 3)))
+
+;;
+;; vector-copy
+;;
+
+(with-test-prefix "vector-copy"
+
+ (pass-if-equal "1 arg"
+ '#(a b c d e f g h i)
+ (vector-copy '#(a b c d e f g h i)))
+
+ (pass-if-equal "2 args"
+ '#(g h i)
+ (vector-copy '#(a b c d e f g h i) 6))
+
+ (pass-if-equal "3 args"
+ '#(d e f)
+ (vector-copy '#(a b c d e f g h i) 3 6))
+
+ (pass-if-equal "4 args"
+ '#(g h i x x x)
+ (vector-copy '#(a b c d e f g h i) 6 12 'x))
+
+ (pass-if-equal "3 args, empty range"
+ '#()
+ (vector-copy '#(a b c d e f g h i) 6 6))
+
+ (pass-if-error "3 args, invalid range"
+ (vector-copy '#(a b c d e f g h i) 4 2)))
+
+;;
+;; vector-reverse-copy
+;;
+
+(with-test-prefix "vector-reverse-copy"
+
+ (pass-if-equal "1 arg"
+ '#(e d c b a)
+ (vector-reverse-copy '#(a b c d e)))
+
+ (pass-if-equal "2 args"
+ '#(e d c)
+ (vector-reverse-copy '#(a b c d e) 2))
+
+ (pass-if-equal "3 args"
+ '#(d c b)
+ (vector-reverse-copy '#(a b c d e) 1 4))
+
+ (pass-if-equal "3 args, empty result"
+ '#()
+ (vector-reverse-copy '#(a b c d e) 1 1))
+
+ (pass-if-error "2 args, invalid range"
+ (vector-reverse-copy '#(a b c d e) 2 1)))
+
+;;
+;; vector-append
+;;
+
+(with-test-prefix "vector-append"
+
+ (pass-if-equal "no args"
+ '#()
+ (vector-append))
+
+ (pass-if-equal "1 arg"
+ '(#(1 2) #f)
+ (let* ((v (vector 1 2))
+ (v-copy (vector-append v)))
+ (list v-copy (eq? v v-copy))))
+
+ (pass-if-equal "2 args"
+ '#(x y)
+ (vector-append '#(x) '#(y)))
+
+ (pass-if-equal "3 args"
+ '#(x y x y x y)
+ (let ((v '#(x y)))
+ (vector-append v v v)))
+
+ (pass-if-equal "3 args with empty vector"
+ '#(x y)
+ (vector-append '#(x) '#() '#(y)))
+
+ (pass-if-error "3 args with non-vectors"
+ (vector-append '#() 'b 'c)))
+
+;;
+;; vector-concatenate
+;;
+
+(with-test-prefix "vector-concatenate"
+
+ (pass-if-equal "2 vectors"
+ '#(a b c d)
+ (vector-concatenate '(#(a b) #(c d))))
+
+ (pass-if-equal "no vectors"
+ '#()
+ (vector-concatenate '()))
+
+ (pass-if-error "non-vector in list"
+ (vector-concatenate '(#(a b) c))))
+
+;;;
+;;; Predicates
+;;;
+
+;;
+;; vector?
+;;
+
+(with-test-prefix "vector?"
+ (pass-if "empty vector" (vector? '#()))
+ (pass-if "simple" (vector? '#(a b)))
+ (pass-if "list" (not (vector? '(a b))))
+ (pass-if "symbol" (not (vector? 'a))))
+
+;;
+;; vector-empty?
+;;
+
+(with-test-prefix "vector-empty?"
+ (pass-if "empty vector" (vector-empty? '#()))
+ (pass-if "singleton vector" (not (vector-empty? '#(a))))
+ (pass-if-error "non-vector" (vector-empty 'a)))
+
+;;
+;; vector=
+;;
+
+(with-test-prefix "vector="
+
+ (pass-if "2 equal vectors"
+ (vector= eq? '#(a b c d) '#(a b c d)))
+
+ (pass-if "3 equal vectors"
+ (vector= eq? '#(a b c d) '#(a b c d) '#(a b c d)))
+
+ (pass-if "2 empty vectors"
+ (vector= eq? '#() '#()))
+
+ (pass-if "no vectors"
+ (vector= eq?))
+
+ (pass-if "1 vector"
+ (vector= eq? '#(a)))
+
+ (pass-if "2 unequal vectors of equal length"
+ (not (vector= eq? '#(a b c d) '#(a b d c))))
+
+ (pass-if "3 unequal vectors of equal length"
+ (not (vector= eq? '#(a b c d) '#(a b c d) '#(a b d c))))
+
+ (pass-if "2 vectors of unequal length"
+ (not (vector= eq? '#(a b c) '#(a b c d))))
+
+ (pass-if "3 vectors of unequal length"
+ (not (vector= eq? '#(a b c d) '#(a b c d) '#(a b c))))
+
+ (pass-if "2 vectors: empty, non-empty"
+ (not (vector= eq? '#() '#(a b d c))))
+
+ (pass-if "2 vectors: non-empty, empty"
+ (not (vector= eq? '#(a b d c) '#())))
+
+ (pass-if "2 equal vectors, elt= is equal?"
+ (vector= equal? '#("a" "b" "c") '#("a" "b" "c")))
+
+ (pass-if "2 equal vectors, elt= is ="
+ (vector= = '#(1/2 1/3 1/4 1/5) '#(1/2 1/3 1/4 1/5)))
+
+ (pass-if-error "vector and list"
+ (vector= equal? '#("a" "b" "c") '("a" "b" "c")))
+
+ (pass-if-error "non-procedure"
+ (vector= 1 '#("a" "b" "c") '("a" "b" "c"))))
+
+;;;
+;;; Selectors
+;;;
+
+;;
+;; vector-ref
+;;
+
+(with-test-prefix "vector-ref"
+ (pass-if-equal "simple 0" 'a (vector-ref '#(a b c) 0))
+ (pass-if-equal "simple 1" 'b (vector-ref '#(a b c) 1))
+ (pass-if-equal "simple 2" 'c (vector-ref '#(a b c) 2))
+ (pass-if-error "negative index" (vector-ref '#(a b c) -1))
+ (pass-if-error "index beyond end" (vector-ref '#(a b c) 3))
+ (pass-if-error "empty vector" (vector-ref '#() 0))
+ (pass-if-error "non-vector" (vector-ref '(a b c) 0))
+ (pass-if-error "inexact index" (vector-ref '#(a b c) 1.0)))
+
+;;
+;; vector-length
+;;
+
+(with-test-prefix "vector-length"
+ (pass-if-equal "empty vector" 0 (vector-length '#()))
+ (pass-if-equal "simple" 3 (vector-length '#(a b c)))
+ (pass-if-error "non-vector" (vector-length '(a b c))))
+
+;;;
+;;; Iteration
+;;;
+
+;;
+;; vector-fold
+;;
+
+(with-test-prefix "vector-fold"
+
+ (pass-if-equal "1 vector"
+ 10
+ (vector-fold (lambda (i seed val) (+ seed val))
+ 0
+ '#(0 1 2 3 4)))
+
+ (pass-if-equal "1 empty vector"
+ 'a
+ (vector-fold (lambda (i seed val) (+ seed val))
+ 'a
+ '#()))
+
+ (pass-if-equal "1 vector, use index"
+ 30
+ (vector-fold (lambda (i seed val) (+ seed (* i val)))
+ 0
+ '#(0 1 2 3 4)))
+
+ (pass-if-equal "2 vectors, unequal lengths"
+ '(1 -7 1 -1)
+ (vector-fold (lambda (i seed x y) (cons (- x y) seed))
+ '()
+ '#(6 1 2 3 4) '#(7 0 9 2)))
+
+ (pass-if-equal "3 vectors, unequal lengths"
+ '(51 33 31 19)
+ (vector-fold (lambda (i seed x y z) (cons (- x y z) seed))
+ '()
+ '#(6 1 2 3 4) '#(7 0 9 2) '#(-20 -30 -40 -50 -60 -70)))
+
+ (pass-if-error "5 args, non-vector"
+ (vector-fold (lambda (i seed x y z) (cons (- x y z) seed))
+ '()
+ '#(6 1 2 3 4) '#(7 0 9 2) '(-20 -30 -40 -50 -60 -70)))
+
+ (pass-if-error "non-procedure"
+ (vector-fold 1 '() '#(6 1 2 3 4) '#(7 0 9 2))))
+
+;;
+;; vector-fold-right
+;;
+
+(with-test-prefix "vector-fold-right"
+
+ (pass-if-equal "1 vector"
+ '((0 . a) (1 . b) (2 . c) (3 . d) (4 . e))
+ (vector-fold-right (lambda (i seed val) (cons (cons i val) seed))
+ '()
+ '#(a b c d e)))
+
+ (pass-if-equal "2 vectors, unequal lengths"
+ '(-1 1 -7 1)
+ (vector-fold-right (lambda (i seed x y) (cons (- x y) seed))
+ '()
+ '#(6 1 2 3 7) '#(7 0 9 2)))
+
+ (pass-if-equal "3 vectors, unequal lengths"
+ '(19 31 33 51)
+ (vector-fold-right (lambda (i seed x y z) (cons (- x y z) seed))
+ '()
+ '#(6 1 2 3 4) '#(7 0 9 2) '#(-20 -30 -40 -50 -60 -70)))
+
+ (pass-if-error "5 args, non-vector"
+ (vector-fold-right (lambda (i seed x y z) (cons (- x y z) seed))
+ '()
+ '#(6 1 2 3 4) '#(7 0 9 2) '(-20 -30 -40 -50 -60 -70)))
+
+ (pass-if-error "non-procedure"
+ (vector-fold-right 1 '() '#(6 1 2 3 4) '#(7 0 9 2))))
+
+;;
+;; vector-map
+;;
+
+(with-test-prefix "vector-map"
+
+ (pass-if-equal "1 vector"
+ '#((0 . a) (1 . b) (2 . c) (3 . d) (4 . e))
+ (vector-map cons '#(a b c d e)))
+
+ (pass-if-equal "1 empty vector"
+ '#()
+ (vector-map cons '#()))
+
+ (pass-if-equal "2 vectors, unequal lengths"
+ '#(5 8 11 14)
+ (vector-map + '#(0 1 2 3 4) '#(5 6 7 8)))
+
+ (pass-if-equal "3 vectors, unequal lengths"
+ '#(15 28 41 54)
+ (vector-map + '#(0 1 2 3 4) '#(5 6 7 8) '#(10 20 30 40 50 60)))
+
+ (pass-if-error "4 args, non-vector"
+ (vector-map + '#(0 1 2 3 4) '(5 6 7 8) '#(10 20 30 40 50 60)))
+
+ (pass-if-error "3 args, non-vector"
+ (vector-map + '#(0 1 2 3 4) '(5 6 7 8)))
+
+ (pass-if-error "non-procedure"
+ (vector-map #f '#(0 1 2 3 4) '#(5 6 7 8) '#(10 20 30 40 50 60))))
+
+;;
+;; vector-map!
+;;
+
+(with-test-prefix "vector-map!"
+
+ (pass-if-equal "1 vector"
+ '#(0 1 4 9 16)
+ (let ((v (vector 0 1 2 3 4)))
+ (vector-map! * v)
+ v))
+
+ (pass-if-equal "1 empty vector"
+ '#()
+ (let ((v (vector)))
+ (vector-map! * v)
+ v))
+
+ (pass-if-equal "2 vectors, unequal lengths"
+ '#(5 8 11 14 4)
+ (let ((v (vector 0 1 2 3 4)))
+ (vector-map! + v '#(5 6 7 8))
+ v))
+
+ (pass-if-equal "3 vectors, unequal lengths"
+ '#(15 28 41 54 4)
+ (let ((v (vector 0 1 2 3 4)))
+ (vector-map! + v '#(5 6 7 8) '#(10 20 30 40 50 60))
+ v))
+
+ (pass-if-error "non-vector"
+ (let ((v (vector 0 1 2 3 4)))
+ (vector-map! + v '#(5 6 7 8) '(10 20 30 40 50 60))
+ v))
+
+ (pass-if-error "non-procedure"
+ (let ((v (vector 0 1 2 3 4)))
+ (vector-map! '(1 . 2) v '#(5 6 7 8) '#(10 20 30 40 50 60))
+ v)))
+
+;;
+;; vector-for-each
+;;
+
+(with-test-prefix "vector-for-each"
+
+ (pass-if-equal "1 vector"
+ '(4 6 6 4 0)
+ (let ((lst '()))
+ (vector-for-each (lambda (i x)
+ (set! lst (cons (* i x) lst)))
+ '#(5 4 3 2 1))
+ lst))
+
+ (pass-if-equal "1 empty vector"
+ '()
+ (let ((lst '()))
+ (vector-for-each (lambda (i x)
+ (set! lst (cons (* i x) lst)))
+ '#())
+ lst))
+
+ (pass-if-equal "2 vectors, unequal lengths"
+ '(13 11 7 2)
+ (let ((lst '()))
+ (vector-for-each (lambda (i x y)
+ (set! lst (cons (+ (* i x) y) lst)))
+ '#(5 4 3 2 1)
+ '#(2 3 5 7))
+ lst))
+
+ (pass-if-equal "3 vectors, unequal lengths"
+ '(-6 -6 -6 -9)
+ (let ((lst '()))
+ (vector-for-each (lambda (i x y z)
+ (set! lst (cons (+ (* i x) (- y z)) lst)))
+ '#(5 4 3 2 1)
+ '#(2 3 5 7)
+ '#(11 13 17 19 23 29))
+ lst))
+
+ (pass-if-error "non-vector"
+ (let ((lst '()))
+ (vector-for-each (lambda (i x y z)
+ (set! lst (cons (+ (* i x) (- y z)) lst)))
+ '#(5 4 3 2 1)
+ '(2 3 5 7)
+ '#(11 13 17 19 23 29))
+ lst))
+
+ (pass-if-error "non-procedure"
+ (let ((lst '()))
+ (vector-for-each '#(not a procedure)
+ '#(5 4 3 2 1)
+ '#(2 3 5 7)
+ '#(11 13 17 19 23 29))
+ lst)))
+
+;;
+;; vector-count
+;;
+
+(with-test-prefix "vector-count"
+
+ (pass-if-equal "1 vector"
+ 3
+ (vector-count (lambda (i x) (even? (+ i x))) '#(2 3 5 7 11)))
+
+ (pass-if-equal "1 empty vector"
+ 0
+ (vector-count values '#()))
+
+ (pass-if-equal "2 vectors, unequal lengths"
+ 3
+ (vector-count (lambda (i x y) (< x (* i y)))
+ '#(8 2 7 8 9 1 0)
+ '#(7 6 4 3 1)))
+
+ (pass-if-equal "3 vectors, unequal lengths"
+ 2
+ (vector-count (lambda (i x y z) (<= x (- y i) z))
+ '#(3 6 3 0 2 4 1)
+ '#(8 7 4 4 9)
+ '#(7 6 8 3 1 7 9)))
+
+ (pass-if-error "non-vector"
+ (vector-count (lambda (i x y z) (<= x (- y i) z))
+ '#(3 6 3 0 2 4 1)
+ '#(8 7 4 4 9)
+ '(7 6 8 3 1 7 9)))
+
+ (pass-if-error "non-procedure"
+ (vector-count '(1 2)
+ '#(3 6 3 0 2 4 1)
+ '#(8 7 4 4 9)
+ '#(7 6 8 3 1 7 9))))
+
+;;;
+;;; Searching
+;;;
+
+;;
+;; vector-index
+;;
+
+(with-test-prefix "vector-index"
+
+ (pass-if-equal "1 vector"
+ 2
+ (vector-index even? '#(3 1 4 1 6 9)))
+
+ (pass-if-equal "2 vectors, unequal lengths, success"
+ 1
+ (vector-index < '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
+
+ (pass-if-equal "2 vectors, unequal lengths, failure"
+ #f
+ (vector-index = '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
+
+ (pass-if-error "non-procedure"
+ (vector-index 1 '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
+
+ (pass-if-error "3 args, non-vector"
+ (vector-index = '#(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
+
+ (pass-if-error "4 args, non-vector"
+ (vector-index = '#(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2) '#(1 2 3)))
+
+ (pass-if-equal "3 vectors, unequal lengths, success"
+ 1
+ (vector-index <
+ '#(3 1 4 1 5 9 2 5 6)
+ '#(2 6 1 7 2)
+ '#(2 7 1 8)))
+
+ (pass-if-equal "3 vectors, unequal lengths, failure"
+ #f
+ (vector-index <
+ '#(3 1 4 1 5 9 2 5 6)
+ '#(2 7 1 7 2)
+ '#(2 7 1 7)))
+
+ (pass-if-equal "empty vector"
+ #f
+ (vector-index < '#() '#(2 7 1 8 2))))
+
+;;
+;; vector-index-right
+;;
+
+(with-test-prefix "vector-index-right"
+
+ (pass-if-equal "1 vector"
+ 4
+ (vector-index-right even? '#(3 1 4 1 6 9)))
+
+ (pass-if-equal "2 vectors, unequal lengths, success"
+ 3
+ (vector-index-right < '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
+
+ (pass-if-equal "2 vectors, unequal lengths, failure"
+ #f
+ (vector-index-right = '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
+
+ (pass-if-error "non-procedure"
+ (vector-index-right 1 '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
+
+ (pass-if-error "3 args, non-vector"
+ (vector-index-right = '#(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
+
+ (pass-if-error "4 args, non-vector"
+ (vector-index-right = '#(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2) '#(1 2 3)))
+
+ (pass-if-equal "3 vectors, unequal lengths, success"
+ 3
+ (vector-index-right <
+ '#(3 1 4 1 5 9 2 5 6)
+ '#(2 6 1 7 2)
+ '#(2 7 1 8)))
+
+ (pass-if-equal "3 vectors, unequal lengths, failure"
+ #f
+ (vector-index-right <
+ '#(3 1 4 1 5 9 2 5 6)
+ '#(2 7 1 7 2)
+ '#(2 7 1 7)))
+
+ (pass-if-equal "empty vector"
+ #f
+ (vector-index-right < '#() '#(2 7 1 8 2))))
+
+;;
+;; vector-skip
+;;
+
+(with-test-prefix "vector-skip"
+
+ (pass-if-equal "1 vector"
+ 2
+ (vector-skip odd? '#(3 1 4 1 6 9)))
+
+ (pass-if-equal "2 vectors, unequal lengths, success"
+ 1
+ (vector-skip >= '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
+
+ (pass-if-equal "2 vectors, unequal lengths, failure"
+ #f
+ (vector-skip (negate =) '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
+
+ (pass-if-error "non-procedure"
+ (vector-skip 1 '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
+
+ (pass-if-error "3 args, non-vector"
+ (vector-skip = '#(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
+
+ (pass-if-error "4 args, non-vector"
+ (vector-skip = '#(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2) '#(1 2 3)))
+
+ (pass-if-equal "3 vectors, unequal lengths, success"
+ 1
+ (vector-skip (negate <)
+ '#(3 1 4 1 5 9 2 5 6)
+ '#(2 6 1 7 2)
+ '#(2 7 1 8)))
+
+ (pass-if-equal "3 vectors, unequal lengths, failure"
+ #f
+ (vector-skip (negate <)
+ '#(3 1 4 1 5 9 2 5 6)
+ '#(2 7 1 7 2)
+ '#(2 7 1 7)))
+
+ (pass-if-equal "empty vector"
+ #f
+ (vector-skip (negate <) '#() '#(2 7 1 8 2))))
+
+;;
+;; vector-skip-right
+;;
+
+(with-test-prefix "vector-skip-right"
+
+ (pass-if-equal "1 vector"
+ 4
+ (vector-skip-right odd? '#(3 1 4 1 6 9)))
+
+ (pass-if-equal "2 vectors, unequal lengths, success"
+ 3
+ (vector-skip-right >= '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
+
+ (pass-if-equal "2 vectors, unequal lengths, failure"
+ #f
+ (vector-skip-right (negate =) '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
+
+ (pass-if-error "non-procedure"
+ (vector-skip-right 1 '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
+
+ (pass-if-error "3 args, non-vector"
+ (vector-skip-right = '#(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
+
+ (pass-if-error "4 args, non-vector"
+ (vector-skip-right = '#(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2) '#(1 2 3)))
+
+ (pass-if-equal "3 vectors, unequal lengths, success"
+ 3
+ (vector-skip-right (negate <)
+ '#(3 1 4 1 5 9 2 5 6)
+ '#(2 6 1 7 2)
+ '#(2 7 1 8)))
+
+ (pass-if-equal "3 vectors, unequal lengths, failure"
+ #f
+ (vector-skip-right (negate <)
+ '#(3 1 4 1 5 9 2 5 6)
+ '#(2 7 1 7 2)
+ '#(2 7 1 7)))
+
+ (pass-if-equal "empty vector"
+ #f
+ (vector-skip-right (negate <) '#() '#(2 7 1 8 2))))
+
+;;
+;; vector-binary-search
+;;
+
+(with-test-prefix "vector-binary-search"
+
+ (define (char-cmp c1 c2)
+ (cond ((char<? c1 c2) -1)
+ ((char=? c1 c2) 0)
+ (else 1)))
+
+ (pass-if-equal "success"
+ 6
+ (vector-binary-search '#(#\a #\b #\c #\d #\e #\f #\g #\h)
+ #\g
+ char-cmp))
+
+ (pass-if-equal "failure"
+ #f
+ (vector-binary-search '#(#\a #\b #\c #\d #\e #\f #\g)
+ #\q
+ char-cmp))
+
+ (pass-if-equal "singleton vector, success"
+ 0
+ (vector-binary-search '#(#\a)
+ #\a
+ char-cmp))
+
+ (pass-if-equal "empty vector"
+ #f
+ (vector-binary-search '#()
+ #\a
+ char-cmp))
+
+ (pass-if-error "first element"
+ (vector-binary-search '(#\a #\b #\c)
+ #\a
+ char-cmp))
+
+ (pass-if-equal "specify range, success"
+ 3
+ (vector-binary-search '#(#\a #\b #\c #\d #\e #\f #\g #\h)
+ #\d
+ char-cmp
+ 2 6))
+
+ (pass-if-equal "specify range, failure"
+ #f
+ (vector-binary-search '#(#\a #\b #\c #\d #\e #\f #\g #\h)
+ #\g
+ char-cmp
+ 2 6)))
+
+;;
+;; vector-any
+;;
+
+(with-test-prefix "vector-any"
+
+ (pass-if-equal "1 vector, success"
+ #t
+ (vector-any even? '#(3 1 4 1 5 9 2)))
+
+ (pass-if-equal "1 vector, failure"
+ #f
+ (vector-any even? '#(3 1 5 1 5 9 1)))
+
+ (pass-if-equal "1 vector, left-to-right"
+ #t
+ (vector-any even? '#(3 1 4 1 5 #f 2)))
+
+ (pass-if-equal "1 vector, left-to-right"
+ 4
+ (vector-any (lambda (x) (and (even? x) x))
+ '#(3 1 4 1 5 #f 2)))
+
+ (pass-if-equal "1 empty vector"
+ #f
+ (vector-any even? '#()))
+
+ (pass-if-equal "2 vectors, unequal lengths, success"
+ '(1 2)
+ (vector-any (lambda (x y) (and (< x y) (list x y)))
+ '#(3 1 4 1 5 #f)
+ '#(1 0 1 2 3)))
+
+ (pass-if-equal "2 vectors, unequal lengths, failure"
+ #f
+ (vector-any < '#(3 1 4 1 5 #f) '#(1 0 1 0 3)))
+
+ (pass-if-equal "3 vectors, unequal lengths, success"
+ '(1 2 3)
+ (vector-any (lambda (x y z) (and (< x y z) (list x y z)))
+ '#(3 1 4 1 3 #f)
+ '#(1 0 1 2 4)
+ '#(2 1 6 3 5)))
+
+ (pass-if-equal "3 vectors, unequal lengths, failure"
+ #f
+ (vector-any <
+ '#(3 1 4 1 5 #f)
+ '#(1 0 3 2)
+ '#(2 1 6 2 3))))
+
+;;
+;; vector-every
+;;
+
+(with-test-prefix "vector-every"
+
+ (pass-if-equal "1 vector, failure"
+ #f
+ (vector-every odd? '#(3 1 4 1 5 9 2)))
+
+ (pass-if-equal "1 vector, success"
+ 11
+ (vector-every (lambda (x) (and (odd? x) x))
+ '#(3 5 7 1 5 9 11)))
+
+ (pass-if-equal "1 vector, left-to-right, failure"
+ #f
+ (vector-every odd? '#(3 1 4 1 5 #f 2)))
+
+ (pass-if-equal "1 empty vector"
+ #t
+ (vector-every even? '#()))
+
+ (pass-if-equal "2 vectors, unequal lengths, left-to-right, failure"
+ #f
+ (vector-every >= '#(3 1 4 1 5) '#(1 0 1 2 3 #f)))
+
+ (pass-if-equal "2 vectors, unequal lengths, left-to-right, success"
+ '(5 3)
+ (vector-every (lambda (x y) (and (>= x y) (list x y)))
+ '#(3 1 4 1 5)
+ '#(1 0 1 0 3 #f)))
+
+ (pass-if-equal "3 vectors, unequal lengths, left-to-right, failure"
+ #f
+ (vector-every >=
+ '#(3 1 4 1 5)
+ '#(1 0 1 2 3 #f)
+ '#(0 0 1 2)))
+
+ (pass-if-equal "3 vectors, unequal lengths, left-to-right, success"
+ '(8 5 4)
+ (vector-every (lambda (x y z) (and (>= x y z) (list x y z)))
+ '#(3 5 4 8 5)
+ '#(2 3 4 5 3 #f)
+ '#(1 2 3 4))))
+
+;;;
+;;; Mutators
+;;;
+
+;;
+;; vector-set!
+;;
+
+(with-test-prefix "vector-set!"
+
+ (pass-if-equal "simple"
+ '#(0 a 2)
+ (let ((v (vector 0 1 2)))
+ (vector-set! v 1 'a)
+ v))
+
+ (pass-if-error "index beyond end" (vector-set! (vector 0 1 2) 3 'a))
+ (pass-if-error "negative index" (vector-set! (vector 0 1 2) -1 'a))
+ (pass-if-error "empty vector" (vector-set! (vector) 0 'a)))
+
+;;
+;; vector-swap!
+;;
+
+(with-test-prefix "vector-swap!"
+
+ (pass-if-equal "simple"
+ '#(b a c)
+ (let ((v (vector 'a 'b 'c)))
+ (vector-swap! v 0 1)
+ v))
+
+ (pass-if-equal "same index"
+ '#(a b c)
+ (let ((v (vector 'a 'b 'c)))
+ (vector-swap! v 1 1)
+ v))
+
+ (pass-if-error "index beyond end" (vector-swap! (vector 'a 'b 'c) 0 3))
+ (pass-if-error "negative index" (vector-swap! (vector 'a 'b 'c) -1 1))
+ (pass-if-error "empty vector" (vector-swap! (vector) 0 0)))
+
+;;
+;; vector-fill!
+;;
+
+(with-test-prefix "vector-fill!"
+
+ (pass-if-equal "2 args"
+ '#(z z z z z)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-fill! v 'z)
+ v))
+
+ (pass-if-equal "3 args"
+ '#(a b z z z)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-fill! v 'z 2)
+ v))
+
+ (pass-if-equal "4 args"
+ '#(a z z d e)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-fill! v 'z 1 3)
+ v))
+
+ (pass-if-equal "4 args, entire vector"
+ '#(z z z z z)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-fill! v 'z 0 5)
+ v))
+
+ (pass-if-equal "4 args, empty range"
+ '#(a b c d e)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-fill! v 'z 2 2)
+ v))
+
+ (pass-if-error "index beyond end" (vector-fill! (vector 'a 'b 'c) 'z 0 4))
+ (pass-if-error "invalid range" (vector-fill! (vector 'a 'b 'c) 'z 2 1))
+ (pass-if-error "negative index" (vector-fill! (vector 'a 'b 'c) 'z -1 1))
+
+ ;; This is intentionally allowed in Guile, as an extension:
+ ;;(pass-if-error "vector-fill! e3" (vector-fill! (vector) 'z 0 0))
+ )
+
+;;
+;; vector-reverse!
+;;
+
+(with-test-prefix "vector-reverse!"
+
+ (pass-if-equal "1 arg"
+ '#(e d c b a)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-reverse! v)
+ v))
+
+ (pass-if-equal "2 args"
+ '#(a b f e d c)
+ (let ((v (vector 'a 'b 'c 'd 'e 'f)))
+ (vector-reverse! v 2)
+ v))
+
+ (pass-if-equal "3 args"
+ '#(a d c b e f)
+ (let ((v (vector 'a 'b 'c 'd 'e 'f)))
+ (vector-reverse! v 1 4)
+ v))
+
+ (pass-if-equal "3 args, empty range"
+ '#(a b c d e f)
+ (let ((v (vector 'a 'b 'c 'd 'e 'f)))
+ (vector-reverse! v 3 3)
+ v))
+
+ (pass-if-equal "3 args, singleton range"
+ '#(a b c d e f)
+ (let ((v (vector 'a 'b 'c 'd 'e 'f)))
+ (vector-reverse! v 3 4)
+ v))
+
+ (pass-if-equal "empty vector"
+ '#()
+ (let ((v (vector)))
+ (vector-reverse! v)
+ v))
+
+ (pass-if-error "index beyond end" (vector-reverse! (vector 'a 'b) 0 3))
+ (pass-if-error "invalid range" (vector-reverse! (vector 'a 'b) 2 1))
+ (pass-if-error "negative index" (vector-reverse! (vector 'a 'b) -1 1))
+
+ ;; This is intentionally allowed in Guile, as an extension:
+ ;;(pass-if-error "vector-reverse! e3" (vector-reverse! (vector) 0 0))
+ )
+
+;;
+;; vector-copy!
+;;
+
+(with-test-prefix "vector-copy!"
+
+ (pass-if-equal "3 args, 0 tstart"
+ '#(1 2 3 d e)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-copy! v 0 '#(1 2 3))
+ v))
+
+ (pass-if-equal "3 args, 2 tstart"
+ '#(a b 1 2 3)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-copy! v 2 '#(1 2 3))
+ v))
+
+ (pass-if-equal "4 args"
+ '#(a b 2 3 e)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-copy! v 2 '#(1 2 3) 1)
+ v))
+
+ (pass-if-equal "5 args"
+ '#(a b 3 4 5)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-copy! v 2 '#(1 2 3 4 5) 2 5)
+ v))
+
+ (pass-if-equal "5 args, empty range"
+ '#(a b c d e)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-copy! v 2 '#(1 2 3) 1 1)
+ v))
+
+ (pass-if-equal "overlapping source/target, moving right"
+ '#(b c c d e)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-copy! v 0 v 1 3)
+ v))
+
+ (pass-if-equal "overlapping source/target, moving left"
+ '#(a b b c d)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-copy! v 2 v 1 4)
+ v))
+
+ (pass-if-equal "overlapping source/target, not moving"
+ '#(a b c d e)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-copy! v 0 v 0)
+ v))
+
+ (pass-if-error "tstart beyond end"
+ (vector-copy! (vector 1 2) 3 '#(1 2 3)))
+ (pass-if-error "would overwrite target end"
+ (vector-copy! (vector 1 2) 0 '#(1 2 3)))
+ (pass-if-error "would overwrite target end"
+ (vector-copy! (vector 1 2) 1 '#(1 2 3) 1)))
+
+;;
+;; vector-reverse-copy!
+;;
+
+(with-test-prefix "vector-reverse-copy!"
+
+ (pass-if-equal "3 args, 0 tstart"
+ '#(3 2 1 d e)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-reverse-copy! v 0 '#(1 2 3))
+ v))
+
+ (pass-if-equal "3 args, 2 tstart"
+ '#(a b 3 2 1)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-reverse-copy! v 2 '#(1 2 3))
+ v))
+
+ (pass-if-equal "4 args"
+ '#(a b 3 2 e)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-reverse-copy! v 2 '#(1 2 3) 1)
+ v))
+
+ (pass-if-equal "5 args"
+ '#(a b 4 3 2)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-reverse-copy! v 2 '#(1 2 3 4 5) 1 4)
+ v))
+
+ (pass-if-equal "5 args, empty range"
+ '#(a b c d e)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-reverse-copy! v 2 '#(1 2 3 4 5) 2 2)
+ v))
+
+ (pass-if-equal "3 args, overlapping source/target"
+ '#(e d c b a)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-reverse-copy! v 0 v)
+ v))
+
+ (pass-if-equal "5 args, overlapping source/target"
+ '#(b a c d e)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-reverse-copy! v 0 v 0 2)
+ v))
+
+ (pass-if-error "3 args, would overwrite target end"
+ (vector-reverse-copy! (vector 'a 'b) 2 '#(a b)))
+ (pass-if-error "3 args, negative tstart"
+ (vector-reverse-copy! (vector 'a 'b) -1 '#(a b)))
+ (pass-if-error "3 args, would overwrite target end"
+ (vector-reverse-copy! (vector 'a 'b) 0 '#(a b c)))
+ (pass-if-error "5 args, send beyond end"
+ (vector-reverse-copy! (vector 'a 'b) 0 '#(a b c) 1 4))
+ (pass-if-error "5 args, negative sstart"
+ (vector-reverse-copy! (vector 'a 'b) 0 '#(a b c) -1 2))
+ (pass-if-error "5 args, invalid source range"
+ (vector-reverse-copy! (vector 'a 'b) 0 '#(a b c) 2 1)))
+
+;;;
+;;; Conversion
+;;;
+
+;;
+;; vector->list
+;;
+
+(with-test-prefix "vector->list"
+
+ (pass-if-equal "1 arg"
+ '(a b c)
+ (vector->list '#(a b c)))
+
+ (pass-if-equal "2 args"
+ '(b c)
+ (vector->list '#(a b c) 1))
+
+ (pass-if-equal "3 args"
+ '(b c d)
+ (vector->list '#(a b c d e) 1 4))
+
+ (pass-if-equal "3 args, empty range"
+ '()
+ (vector->list '#(a b c d e) 1 1))
+
+ (pass-if-equal "1 arg, empty vector"
+ '()
+ (vector->list '#()))
+
+ (pass-if-error "index beyond end" (vector->list '#(a b c) 1 6))
+ (pass-if-error "negative index" (vector->list '#(a b c) -1 1))
+ (pass-if-error "invalid range" (vector->list '#(a b c) 2 1)))
+
+;;
+;; reverse-vector->list
+;;
+
+(with-test-prefix "reverse-vector->list"
+
+ (pass-if-equal "1 arg"
+ '(c b a)
+ (reverse-vector->list '#(a b c)))
+
+ (pass-if-equal "2 args"
+ '(c b)
+ (reverse-vector->list '#(a b c) 1))
+
+ (pass-if-equal "3 args"
+ '(d c b)
+ (reverse-vector->list '#(a b c d e) 1 4))
+
+ (pass-if-equal "3 args, empty range"
+ '()
+ (reverse-vector->list '#(a b c d e) 1 1))
+
+ (pass-if-equal "1 arg, empty vector"
+ '()
+ (reverse-vector->list '#()))
+
+ (pass-if-error "index beyond end" (reverse-vector->list '#(a b c) 1 6))
+ (pass-if-error "negative index" (reverse-vector->list '#(a b c) -1 1))
+ (pass-if-error "invalid range" (reverse-vector->list '#(a b c) 2 1)))
+
+;;
+;; list->vector
+;;
+
+(with-test-prefix "list->vector"
+
+ (pass-if-equal "1 arg"
+ '#(a b c)
+ (list->vector '(a b c)))
+
+ (pass-if-equal "1 empty list"
+ '#()
+ (list->vector '()))
+
+ (pass-if-equal "2 args"
+ '#(2 3)
+ (list->vector '(0 1 2 3) 2))
+
+ (pass-if-equal "3 args"
+ '#(0 1)
+ (list->vector '(0 1 2 3) 0 2))
+
+ (pass-if-equal "3 args, empty range"
+ '#()
+ (list->vector '(0 1 2 3) 2 2))
+
+ (pass-if-error "index beyond end" (list->vector '(0 1 2 3) 0 5))
+ (pass-if-error "negative index" (list->vector '(0 1 2 3) -1 1))
+ (pass-if-error "invalid range" (list->vector '(0 1 2 3) 2 1)))
+
+;;
+;; reverse-list->vector
+;;
+
+(with-test-prefix "reverse-list->vector"
+
+ (pass-if-equal "1 arg"
+ '#(c b a)
+ (reverse-list->vector '(a b c)))
+
+ (pass-if-equal "1 empty list"
+ '#()
+ (reverse-list->vector '()))
+
+ (pass-if-equal "2 args"
+ '#(3 2)
+ (reverse-list->vector '(0 1 2 3) 2))
+
+ (pass-if-equal "3 args"
+ '#(1 0)
+ (reverse-list->vector '(0 1 2 3) 0 2))
+
+ (pass-if-equal "3 args, empty range"
+ '#()
+ (reverse-list->vector '(0 1 2 3) 2 2))
+
+ (pass-if-error "index beyond end"
+ (reverse-list->vector '(0 1 2 3) 0 5))
+
+ (pass-if-error "negative index"
+ (reverse-list->vector '(0 1 2 3) -1 1))
+
+ (pass-if-error "invalid range"
+ (reverse-list->vector '(0 1 2 3) 2 1)))
+
+;;; Local Variables:
+;;; eval: (put 'pass-if-error 'scheme-indent-function 1)
+;;; End:
--
1.7.5.4
- [PATCH] Implement SRFI-43 Vector Library,
Mark H Weaver <=