From 451ea8b6a5abdc37f481ceaf481127e35d6bc381 Mon Sep 17 00:00:00 2001 From: Mark H Weaver 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) + (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 + +(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 , 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= '#(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