* [PATCH] Implement SRFI-43 Vector Library
@ 2014-01-28 7:05 Mark H Weaver
2014-01-28 7:40 ` Mark H Weaver
2014-01-29 6:25 ` Nala Ginrut
0 siblings, 2 replies; 4+ messages in thread
From: Mark H Weaver @ 2014-01-28 7:05 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 1287 bytes --]
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
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: [PATCH] Implement SRFI-43 Vector Library --]
[-- Type: text/x-patch, Size: 95016 bytes --]
From 451ea8b6a5abdc37f481ceaf481127e35d6bc381 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
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}.
+@node SRFI-43
+@subsection SRFI-43 - Vector Library
+@cindex SRFI-43
+
+This subsection is based on the
+@uref{http://srfi.schemers.org/srfi-43/srfi-43.html, specification of
+SRFI-43} by Taylor Campbell.
+
+@c The copyright notice and license text of the SRFI-43 specification is
+@c reproduced below:
+
+@c Copyright (C) Taylor Campbell (2003). All Rights Reserved.
+
+@c Permission is hereby granted, free of charge, to any person obtaining a
+@c copy of this software and associated documentation files (the
+@c "Software"), to deal in the Software without restriction, including
+@c without limitation the rights to use, copy, modify, merge, publish,
+@c distribute, sublicense, and/or sell copies of the Software, and to
+@c permit persons to whom the Software is furnished to do so, subject to
+@c the following conditions:
+
+@c The above copyright notice and this permission notice shall be included
+@c in all copies or substantial portions of the Software.
+
+@c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
+@c OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+@c MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+@c NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+@c LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+@c OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+@c WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+@noindent
+This SRFI implements a comprehensive library of vector operations,
+analogous to the SRFI-1 list library. SRFI-43 can be made available
+with:
+
+@example
+(use-modules (srfi srfi-43))
+@end example
+
+@menu
+* SRFI-43 Constructors::
+* SRFI-43 Predicates::
+* SRFI-43 Selectors::
+* SRFI-43 Iteration::
+* SRFI-43 Searching::
+* SRFI-43 Mutators::
+* SRFI-43 Conversion::
+@end menu
+
+@node SRFI-43 Constructors
+@subsubsection SRFI-43 Constructors
+
+@deffn {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.
+
+@example
+(make-vector 5 3) @result{} #(3 3 3 3 3)
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} vector x @dots{}
+Create and return a vector whose elements are @var{x} @enddots{}.
+
+@example
+(vector 0 1 2 3 4) @result{} #(0 1 2 3 4)
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} vector-unfold f length initial-seed @dots{}
+The fundamental vector constructor. Create a vector whose length is
+@var{length} and iterates across each index k from 0 up to
+@var{length} - 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.
+
+@example
+(vector-unfold (lambda (i x) (values x (- x 1)))
+ 10 0)
+@result{} #(0 -1 -2 -3 -4 -5 -6 -7 -8 -9)
+
+(vector-unfold values 10)
+@result{} #(0 1 2 3 4 5 6 7 8 9)
+@end example
+@end deffn
+
+@deffn {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.
+
+@example
+(vector-unfold-right (lambda (i x) (values x (+ x 1)))
+ 10 0)
+@result{} #(9 8 7 6 5 4 3 2 1 0)
+@end example
+@end deffn
+
+@deffn {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
+@var{start} and stopping at index @var{end}. @var{start} defaults to 0
+and @var{end} defaults to the value of @code{(vector-length vec)}. If
+@var{end} 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.
+
+@example
+(vector-copy '#(a b c d e f g h i))
+@result{} #(a b c d e f g h i)
+
+(vector-copy '#(a b c d e f g h i) 6)
+@result{} #(g h i)
+
+(vector-copy '#(a b c d e f g h i) 3 6)
+@result{} #(d e f)
+
+(vector-copy '#(a b c d e f g h i) 6 12 'x)
+@result{} #(g h i x x x)
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} vector-reverse-copy vec [start [end]]
+Like @code{vector-copy}, but it copies the elements in the reverse order
+from @var{vec}.
+
+@example
+(vector-reverse-copy '#(5 4 3 2 1 0) 1 5)
+@result{} #(1 2 3 4)
+@end example
+@end deffn
+
+@deffn {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{}.
+
+@example
+(vector-append '#(a) '#(b c d))
+@result{} #(a b c d)
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} vector-concatenate list-of-vectors
+Append each vector in @var{list-of-vectors}. Equivalent to
+@code{(apply vector-append list-of-vectors)}.
+
+@example
+(vector-concatenate '(#(a b) #(c d)))
+@result{} #(a b c d)
+@end example
+@end deffn
+
+@node SRFI-43 Predicates
+@subsubsection SRFI-43 Predicates
+
+@deffn {Scheme Procedure} vector? obj
+Return true if @var{obj} is a vector, else return false.
+@end deffn
+
+@deffn {Scheme Procedure} vector-empty? vec
+Return true if @var{vec} is empty, i.e. its length is 0, else return
+false.
+@end deffn
+
+@deffn {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
+@code{(elt=? a b)} must also return true. The order in which
+comparisons are performed is unspecified.
+@end deffn
+
+@node SRFI-43 Selectors
+@subsubsection SRFI-43 Selectors
+
+@deffn {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.
+@end deffn
+
+@deffn {Scheme Procedure} vector-length vec
+Returns the length of @var{vec}.
+@end deffn
+
+@node SRFI-43 Iteration
+@subsubsection SRFI-43 Iteration
+
+@deffn {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
+@smalllisp
+(kons i state (vector-ref vec1 i) (vector-ref vec2 i) ...)
+@end 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.
+@end deffn
+
+@deffn {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.
+@end deffn
+
+@deffn {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
+@smalllisp
+(f i (vector-ref vec1 i) (vector-ref vec2 i) ...)}
+@end smalllisp
+The dynamic order of application of @var{f} is unspecified.
+@end deffn
+
+@deffn {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.
+@end deffn
+
+@deffn {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.
+@end deffn
+
+@deffn {Scheme Procedure} vector-count pred? vec1 vec2 @dots{}
+Count the number of parallel elements in the vectors that satisfy
+@var{pred?}, 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.
+
+@example
+(vector-count (lambda (i elt) (even? elt))
+ '#(3 1 4 1 5 9 2 5 6))
+@result{} 3
+(vector-count (lambda (i x y) (< x y))
+ '#(1 3 6 9) '#(2 4 6 8 10 12))
+@result{} 2
+@end example
+@end deffn
+
+@node SRFI-43 Searching
+@subsubsection SRFI-43 Searching
+
+@deffn {Scheme Procedure} vector-index pred? vec1 vec2 @dots{}
+Find and return the index of the first elements in @var{vec1} @var{vec2}
+@dots{} that satisfy @var{pred?}. If no matching element is found by
+the end of the shortest vector, return @code{#f}.
+
+@example
+(vector-index even? '#(3 1 4 1 5 9))
+@result{} 2
+(vector-index < '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2))
+@result{} 1
+(vector-index = '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2))
+@result{} #f
+@end example
+@end deffn
+
+@deffn {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.
+@end deffn
+
+@deffn {Scheme Procedure} vector-skip pred? vec1 vec2 @dots{}
+Find and return the index of the first elements in @var{vec1} @var{vec2}
+@dots{} 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.
+
+@example
+(vector-skip number? '#(1 2 a b 3 4 c d)) @result{} 2
+@end example
+@end deffn
+
+@deffn {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.
+@end deffn
+
+@deffn {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
+@math{a = b}. The elements of @var{vec} must be sorted in
+non-decreasing order according to @var{cmp}.
+
+@example
+(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)
+@result{} 6
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} vector-any pred? vec1 vec2 @dots{}
+Find the first parallel set of elements from @var{vec1} @var{vec2}
+@dots{} for which @var{pred?} returns a true value. If such a parallel
+set of elements exists, @code{vector-any} returns the value that
+@var{pred?} returned for that set of elements. The iteration is
+strictly left-to-right.
+@end deffn
+
+@deffn {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)}
+@code{(vector-ref vec2 i)} @dots{} satisfies @var{pred?},
+@code{vector-every} 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.
+@end deffn
+
+@node SRFI-43 Mutators
+@subsubsection SRFI-43 Mutators
+
+@deffn {Scheme Procedure} vector-set! vec i value
+Assign the contents of the location at @var{i} in @var{vec} to
+@var{value}.
+@end deffn
+
+@deffn {Scheme Procedure} vector-swap! vec i j
+Swap the values of the locations in @var{vec} at @var{i} and @var{j}.
+@end deffn
+
+@deffn {Scheme Procedure} vector-fill! vec fill [start [end]]
+Assign the value of every location in @var{vec} between @var{start} and
+@var{end} to @var{fill}. @var{start} defaults to 0 and @var{end}
+defaults to the length of @var{vec}.
+@end deffn
+
+@deffn {Scheme Procedure} vector-reverse! vec [start [end]]
+Destructively reverse the contents of @var{vec} between @var{start} and
+@var{end}. @var{start} defaults to 0 and @var{end} defaults to the
+length of @var{vec}.
+@end deffn
+
+@deffn {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} -
+@var{sstart}) elements have been copied. It is an error for
+@var{target} to have a length less than (@var{tstart} + @var{send} -
+@var{sstart}). @var{sstart} defaults to 0 and @var{send} defaults to
+the length of @var{source}.
+@end deffn
+
+@deffn {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
+@code{(vector-reverse! target tstart send)} would.
+@end deffn
+
+@node SRFI-43 Conversion
+@subsubsection SRFI-43 Conversion
+
+@deffn {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
+@var{end} defaults to the length of @var{vec}.
+@end deffn
+
+@deffn {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.
+@end deffn
+
+@deffn {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.
+@end deffn
+
+@deffn {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.
+@end 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 <mhw@netris.org>
+
+(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 <mhw@netris.org>, 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
^ permalink raw reply related [flat|nested] 4+ messages in thread
* Re: [PATCH] Implement SRFI-43 Vector Library
2014-01-28 7:05 [PATCH] Implement SRFI-43 Vector Library Mark H Weaver
@ 2014-01-28 7:40 ` Mark H Weaver
2014-02-07 13:13 ` Ludovic Courtès
2014-01-29 6:25 ` Nala Ginrut
1 sibling, 1 reply; 4+ messages in thread
From: Mark H Weaver @ 2014-01-28 7:40 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 108 bytes --]
Since posting, I've fixed some mistakes in the texinfo documentation.
Here's an updated patch.
Mark
[-- Warning: decoded text below may be mangled, UTF-8 assumed --]
[-- Attachment #2: [PATCH] Implement SRFI-43 Vector Library --]
[-- Type: text/x-patch, Size: 95160 bytes --]
From 35662c15740a16346a7cc62ae8a87c2cd4c31079 Mon Sep 17 00:00:00 2001
From: Mark H Weaver <mhw@netris.org>
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 | 411 ++++++++++++
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, 2870 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..3501016 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,416 @@ 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}.
+@node SRFI-43
+@subsection SRFI-43 - Vector Library
+@cindex SRFI-43
+
+This subsection is based on the
+@uref{http://srfi.schemers.org/srfi-43/srfi-43.html, specification of
+SRFI-43} by Taylor Campbell.
+
+@c The copyright notice and license text of the SRFI-43 specification is
+@c reproduced below:
+
+@c Copyright (C) Taylor Campbell (2003). All Rights Reserved.
+
+@c Permission is hereby granted, free of charge, to any person obtaining a
+@c copy of this software and associated documentation files (the
+@c "Software"), to deal in the Software without restriction, including
+@c without limitation the rights to use, copy, modify, merge, publish,
+@c distribute, sublicense, and/or sell copies of the Software, and to
+@c permit persons to whom the Software is furnished to do so, subject to
+@c the following conditions:
+
+@c The above copyright notice and this permission notice shall be included
+@c in all copies or substantial portions of the Software.
+
+@c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
+@c OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+@c MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+@c NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
+@c LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
+@c OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
+@c WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+@noindent
+SRFI-43 implements a comprehensive library of vector operations. It can
+be made available with:
+
+@example
+(use-modules (srfi srfi-43))
+@end example
+
+@menu
+* SRFI-43 Constructors::
+* SRFI-43 Predicates::
+* SRFI-43 Selectors::
+* SRFI-43 Iteration::
+* SRFI-43 Searching::
+* SRFI-43 Mutators::
+* SRFI-43 Conversion::
+@end menu
+
+@node SRFI-43 Constructors
+@subsubsection SRFI-43 Constructors
+
+@deffn {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.
+
+@example
+(make-vector 5 3) @result{} #(3 3 3 3 3)
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} vector x @dots{}
+Create and return a vector whose elements are @var{x} @enddots{}.
+
+@example
+(vector 0 1 2 3 4) @result{} #(0 1 2 3 4)
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} vector-unfold f length initial-seed @dots{}
+The fundamental vector constructor. Create a vector whose length is
+@var{length} and iterates across each index k from 0 up to
+@var{length} - 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.
+
+@example
+(vector-unfold (lambda (i x) (values x (- x 1)))
+ 10 0)
+@result{} #(0 -1 -2 -3 -4 -5 -6 -7 -8 -9)
+
+(vector-unfold values 10)
+@result{} #(0 1 2 3 4 5 6 7 8 9)
+@end example
+@end deffn
+
+@deffn {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.
+
+@example
+(vector-unfold-right (lambda (i x) (values x (+ x 1)))
+ 10 0)
+@result{} #(9 8 7 6 5 4 3 2 1 0)
+@end example
+@end deffn
+
+@deffn {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
+@var{start} and stopping at index @var{end}. @var{start} defaults to 0
+and @var{end} defaults to the value of @code{(vector-length vec)}. If
+@var{end} 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.
+
+@example
+(vector-copy '#(a b c d e f g h i))
+@result{} #(a b c d e f g h i)
+
+(vector-copy '#(a b c d e f g h i) 6)
+@result{} #(g h i)
+
+(vector-copy '#(a b c d e f g h i) 3 6)
+@result{} #(d e f)
+
+(vector-copy '#(a b c d e f g h i) 6 12 'x)
+@result{} #(g h i x x x)
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} vector-reverse-copy vec [start [end]]
+Like @code{vector-copy}, but it copies the elements in the reverse order
+from @var{vec}.
+
+@example
+(vector-reverse-copy '#(5 4 3 2 1 0) 1 5)
+@result{} #(1 2 3 4)
+@end example
+@end deffn
+
+@deffn {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{}.
+
+@example
+(vector-append '#(a) '#(b c d))
+@result{} #(a b c d)
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} vector-concatenate list-of-vectors
+Append each vector in @var{list-of-vectors}. Equivalent to
+@code{(apply vector-append list-of-vectors)}.
+
+@example
+(vector-concatenate '(#(a b) #(c d)))
+@result{} #(a b c d)
+@end example
+@end deffn
+
+@node SRFI-43 Predicates
+@subsubsection SRFI-43 Predicates
+
+@deffn {Scheme Procedure} vector? obj
+Return true if @var{obj} is a vector, else return false.
+@end deffn
+
+@deffn {Scheme Procedure} vector-empty? vec
+Return true if @var{vec} is empty, i.e. its length is 0, else return
+false.
+@end deffn
+
+@deffn {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
+@code{(elt=? a b)} must also return true. The order in which
+comparisons are performed is unspecified.
+@end deffn
+
+@node SRFI-43 Selectors
+@subsubsection SRFI-43 Selectors
+
+@deffn {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.
+@end deffn
+
+@deffn {Scheme Procedure} vector-length vec
+Return the length of @var{vec}.
+@end deffn
+
+@node SRFI-43 Iteration
+@subsubsection SRFI-43 Iteration
+
+@deffn {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
+@smalllisp
+(kons i state (vector-ref vec1 i) (vector-ref vec2 i) ...)
+@end 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.
+@end deffn
+
+@deffn {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.
+@end deffn
+
+@deffn {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
+@smalllisp
+(f i (vector-ref vec1 i) (vector-ref vec2 i) ...)
+@end smalllisp
+The dynamic order of application of @var{f} is unspecified.
+@end deffn
+
+@deffn {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.
+@end deffn
+
+@deffn {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.
+@end deffn
+
+@deffn {Scheme Procedure} vector-count pred? vec1 vec2 @dots{}
+Count the number of parallel elements in the vectors that satisfy
+@var{pred?}, 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.
+
+@example
+(vector-count (lambda (i elt) (even? elt))
+ '#(3 1 4 1 5 9 2 5 6))
+@result{} 3
+(vector-count (lambda (i x y) (< x y))
+ '#(1 3 6 9) '#(2 4 6 8 10 12))
+@result{} 2
+@end example
+@end deffn
+
+@node SRFI-43 Searching
+@subsubsection SRFI-43 Searching
+
+@deffn {Scheme Procedure} vector-index pred? vec1 vec2 @dots{}
+Find and return the index of the first elements in @var{vec1} @var{vec2}
+@dots{} that satisfy @var{pred?}. If no matching element is found by
+the end of the shortest vector, return @code{#f}.
+
+@example
+(vector-index even? '#(3 1 4 1 5 9))
+@result{} 2
+(vector-index < '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2))
+@result{} 1
+(vector-index = '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2))
+@result{} #f
+@end example
+@end deffn
+
+@deffn {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.
+@end deffn
+
+@deffn {Scheme Procedure} vector-skip pred? vec1 vec2 @dots{}
+Find and return the index of the first elements in @var{vec1} @var{vec2}
+@dots{} 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.
+
+@example
+(vector-skip number? '#(1 2 a b 3 4 c d)) @result{} 2
+@end example
+@end deffn
+
+@deffn {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.
+@end deffn
+
+@deffn {Scheme Procedure} vector-binary-search vec value cmp [start [end]]
+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 @math{a = b}. The elements of @var{vec} must
+be sorted in non-decreasing order according to @var{cmp}.
+
+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.
+
+@example
+(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)
+@result{} 6
+@end example
+@end deffn
+
+@deffn {Scheme Procedure} vector-any pred? vec1 vec2 @dots{}
+Find the first parallel set of elements from @var{vec1} @var{vec2}
+@dots{} for which @var{pred?} returns a true value. If such a parallel
+set of elements exists, @code{vector-any} returns the value that
+@var{pred?} returned for that set of elements. The iteration is
+strictly left-to-right.
+@end deffn
+
+@deffn {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)}
+@code{(vector-ref vec2 i)} @dots{} satisfies @var{pred?},
+@code{vector-every} 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.
+@end deffn
+
+@node SRFI-43 Mutators
+@subsubsection SRFI-43 Mutators
+
+@deffn {Scheme Procedure} vector-set! vec i value
+Assign the contents of the location at @var{i} in @var{vec} to
+@var{value}.
+@end deffn
+
+@deffn {Scheme Procedure} vector-swap! vec i j
+Swap the values of the locations in @var{vec} at @var{i} and @var{j}.
+@end deffn
+
+@deffn {Scheme Procedure} vector-fill! vec fill [start [end]]
+Assign the value of every location in @var{vec} between @var{start} and
+@var{end} to @var{fill}. @var{start} defaults to 0 and @var{end}
+defaults to the length of @var{vec}.
+@end deffn
+
+@deffn {Scheme Procedure} vector-reverse! vec [start [end]]
+Destructively reverse the contents of @var{vec} between @var{start} and
+@var{end}. @var{start} defaults to 0 and @var{end} defaults to the
+length of @var{vec}.
+@end deffn
+
+@deffn {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} -
+@var{sstart}) elements have been copied. It is an error for
+@var{target} to have a length less than (@var{tstart} + @var{send} -
+@var{sstart}). @var{sstart} defaults to 0 and @var{send} defaults to
+the length of @var{source}.
+@end deffn
+
+@deffn {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
+@code{(vector-reverse! target tstart send)} would.
+@end deffn
+
+@node SRFI-43 Conversion
+@subsubsection SRFI-43 Conversion
+
+@deffn {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
+@var{end} defaults to the length of @var{vec}.
+@end deffn
+
+@deffn {Scheme Procedure} reverse-vector->list vec [start [end]]
+Like @code{vector->list}, but the resulting list contains the specified
+range of elements of @var{vec} in reverse order.
+@end deffn
+
+@deffn {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.
+@end deffn
+
+@deffn {Scheme Procedure} reverse-list->vector proper-list [start [end]]
+Like @code{list->vector}, but the resulting vector contains the 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.
+@end 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 <mhw@netris.org>
+
+(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 <mhw@netris.org>, 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
^ permalink raw reply related [flat|nested] 4+ messages in thread
* Re: [PATCH] Implement SRFI-43 Vector Library
2014-01-28 7:05 [PATCH] Implement SRFI-43 Vector Library Mark H Weaver
2014-01-28 7:40 ` Mark H Weaver
@ 2014-01-29 6:25 ` Nala Ginrut
1 sibling, 0 replies; 4+ messages in thread
From: Nala Ginrut @ 2014-01-29 6:25 UTC (permalink / raw)
To: Mark H Weaver; +Cc: guile-devel
Thanks for doing it! ;-)
^ permalink raw reply [flat|nested] 4+ messages in thread
* Re: [PATCH] Implement SRFI-43 Vector Library
2014-01-28 7:40 ` Mark H Weaver
@ 2014-02-07 13:13 ` Ludovic Courtès
0 siblings, 0 replies; 4+ messages in thread
From: Ludovic Courtès @ 2014-02-07 13:13 UTC (permalink / raw)
To: guile-devel
Mark H Weaver <mhw@netris.org> skribis:
> From 35662c15740a16346a7cc62ae8a87c2cd4c31079 Mon Sep 17 00:00:00 2001
> From: Mark H Weaver <mhw@netris.org>
> 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.
Awesome!
Nothing to say overall, just a little bit of nitpicking:
> +(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)
I think ‘vector-length’ should be aligned with ‘make-vector’.
> + #:replace (vector-copy vector-fill! list->vector vector->list)
> + #:export (vector-empty? vector= vector-unfold vector-unfold-right
> + vector-reverse-copy
Likewise.
> +(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."
I think it’s not necessary to repeat the procedure prototype in the
docstring: we never do that, and the documentation system would print it
anyway.
(BTW, I recently learned that Texinfo in docstring *is* actually
interpreted if (texinfo reflection) is loaded. Tip of the day. ;-))
Nice that you used ‘case-lambda’ to specialize the zero-seed and
one-seed cases; I wonder if it’s really necessary to specialize the
two-seed case, though, as it’s less common, I think. WDYT?
Thanks!
Ludo’.
^ permalink raw reply [flat|nested] 4+ messages in thread
end of thread, other threads:[~2014-02-07 13:13 UTC | newest]
Thread overview: 4+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2014-01-28 7:05 [PATCH] Implement SRFI-43 Vector Library Mark H Weaver
2014-01-28 7:40 ` Mark H Weaver
2014-02-07 13:13 ` Ludovic Courtès
2014-01-29 6:25 ` Nala Ginrut
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).