From: Andy Wingo Date: Fri, 7 Feb 2014 14:13:22 +0000 (+0100) Subject: Merge commit '34e89877342f20fdb8a531ad78dab34cfd2b0843' X-Git-Url: https://git.hcoop.net/bpt/guile.git/commitdiff_plain/cd36c69619e406082100efb1e62998fc67bbc2a6?hp=04f59ec2e7ab73caacbbfa2c5905fe4f240c47c5 Merge commit '34e89877342f20fdb8a531ad78dab34cfd2b0843' Conflicts: module/Makefile.am --- diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi index 726f5c0c5..746ee629d 100644 --- a/doc/ref/srfi-modules.texi +++ b/doc/ref/srfi-modules.texi @@ -47,12 +47,14 @@ 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. * SRFI-60:: Integers as bits. * SRFI-61:: A more general `cond' clause * SRFI-62:: S-expression comments. +* SRFI-64:: A Scheme API for test suites. * SRFI-67:: Compare procedures * SRFI-69:: Basic hash tables. * SRFI-87:: => in case clauses. @@ -4504,6 +4506,417 @@ 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 @var{vec}, taking elements from @var{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) + (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 @@ -4852,6 +5265,13 @@ needed to get SRFI-61 itself. Extended @code{cond} is documented in Starting from version 2.0, Guile's @code{read} supports SRFI-62/R7RS S-expression comments by default. +@node SRFI-64 +@subsection SRFI-64 - A Scheme API for test suites. +@cindex SRFI-64 + +See @uref{http://srfi.schemers.org/srfi-64/srfi-64.html, the +specification of SRFI-64}. + @node SRFI-67 @subsection SRFI-67 - Compare procedures @cindex SRFI-67 diff --git a/module/Makefile.am b/module/Makefile.am index 362170693..d262818bc 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -1,6 +1,7 @@ ## Process this file with automake to produce Makefile.in. ## -## Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. +## Copyright (C) 2009, 2010, 2011, 2012, 2013, +## 2014 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -279,6 +280,8 @@ SCRIPTS_SOURCES += \ endif BUILD_ICE_9_POPEN +srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm + SRFI_SOURCES = \ srfi/srfi-2.scm \ srfi/srfi-4.scm \ @@ -304,9 +307,11 @@ 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 \ + srfi/srfi-64.scm \ srfi/srfi-67.scm \ srfi/srfi-69.scm \ srfi/srfi-88.scm \ @@ -418,6 +423,7 @@ NOCOMP_SOURCES = \ ice-9/r6rs-libraries.scm \ ice-9/quasisyntax.scm \ srfi/srfi-42/ec.scm \ + srfi/srfi-64/testing.scm \ srfi/srfi-67/compare.scm \ system/base/lalr.upstream.scm \ system/repl/describe.scm \ diff --git a/module/srfi/srfi-43.scm b/module/srfi/srfi-43.scm new file mode 100644 index 000000000..88a3f3fec --- /dev/null +++ b/module/srfi/srfi-43.scm @@ -0,0 +1,1077 @@ +;;; 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 len)) + (error-from who "invalid index" i))) + +(define-syntax-rule (assert-valid-start start len who) + (unless (and (exact-integer? start) + (<= 0 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 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 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/module/srfi/srfi-64.scm b/module/srfi/srfi-64.scm new file mode 100644 index 000000000..81dcc5dc5 --- /dev/null +++ b/module/srfi/srfi-64.scm @@ -0,0 +1,55 @@ +;;; srfi-64.scm -- SRFI 64 - A Scheme API for test suites. + +;; 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 + +(define-module (srfi srfi-64) + #:export + (test-begin + test-end test-assert test-eqv test-eq test-equal + test-approximate test-assert test-error test-apply test-with-runner + test-match-nth test-match-all test-match-any test-match-name + test-skip test-expect-fail test-read-eval-string + test-runner-group-path test-group test-group-with-cleanup + test-result-ref test-result-set! test-result-clear test-result-remove + test-result-kind test-passed? + test-log-to-file + test-runner? test-runner-reset test-runner-null + test-runner-simple test-runner-current test-runner-factory test-runner-get + test-runner-create test-runner-test-name + test-runner-pass-count test-runner-pass-count! + test-runner-fail-count test-runner-fail-count! + test-runner-xpass-count test-runner-xpass-count! + test-runner-xfail-count test-runner-xfail-count! + test-runner-skip-count test-runner-skip-count! + test-runner-group-stack test-runner-group-stack! + test-runner-on-test-begin test-runner-on-test-begin! + test-runner-on-test-end test-runner-on-test-end! + test-runner-on-group-begin test-runner-on-group-begin! + test-runner-on-group-end test-runner-on-group-end! + test-runner-on-final test-runner-on-final! + test-runner-on-bad-count test-runner-on-bad-count! + test-runner-on-bad-end-name test-runner-on-bad-end-name! + test-result-alist test-result-alist! + test-runner-aux-value test-runner-aux-value! + test-on-group-begin-simple test-on-group-end-simple + test-on-bad-count-simple test-on-bad-end-name-simple + test-on-final-simple test-on-test-end-simple + test-on-final-simple)) + +(cond-expand-provide (current-module) '(srfi-64)) + +(include-from-path "srfi/srfi-64/testing.scm") diff --git a/module/srfi/srfi-64/testing.scm b/module/srfi/srfi-64/testing.scm new file mode 100644 index 000000000..d686662bf --- /dev/null +++ b/module/srfi/srfi-64/testing.scm @@ -0,0 +1,1040 @@ +;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner +;; Added "full" support for Chicken, Gauche, Guile and SISC. +;; Alex Shinn, Copyright (c) 2005. +;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012. +;; Support for Guile 2 by Mark H Weaver , Copyright (c) 2014. +;; +;; Permission is hereby granted, free of charge, to any person +;; obtaining a copy of this software and associated documentation +;; files (the "Software"), to deal in the Software without +;; restriction, including without limitation the rights to use, copy, +;; modify, merge, publish, distribute, sublicense, and/or sell copies +;; of the Software, and to permit persons to whom the Software is +;; furnished to do so, subject to the following conditions: +;; +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. +;; +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS +;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN +;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN +;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +;; SOFTWARE. + +(cond-expand + (chicken + (require-extension syntax-case)) + (guile-2 + (use-modules (srfi srfi-9) + ;; In 2.0.9, srfi-34 and srfi-35 are not well integrated + ;; with either Guile's native exceptions or R6RS exceptions. + ;;(srfi srfi-34) (srfi srfi-35) + (srfi srfi-39))) + (guile + (use-modules (ice-9 syncase) (srfi srfi-9) + ;;(srfi srfi-34) (srfi srfi-35) - not in Guile 1.6.7 + (srfi srfi-39))) + (sisc + (require-extension (srfi 9 34 35 39))) + (kawa + (module-compile-options warn-undefined-variable: #t + warn-invoke-unknown-method: #t) + (provide 'srfi-64) + (provide 'testing) + (require 'srfi-34) + (require 'srfi-35)) + (else () + )) + +(cond-expand + (kawa + (define-syntax %test-export + (syntax-rules () + ((%test-export test-begin . other-names) + (module-export %test-begin . other-names))))) + (else + (define-syntax %test-export + (syntax-rules () + ((%test-export . names) (if #f #f)))))) + +;; List of exported names +(%test-export + test-begin ;; must be listed first, since in Kawa (at least) it is "magic". + test-end test-assert test-eqv test-eq test-equal + test-approximate test-assert test-error test-apply test-with-runner + test-match-nth test-match-all test-match-any test-match-name + test-skip test-expect-fail test-read-eval-string + test-runner-group-path test-group test-group-with-cleanup + test-result-ref test-result-set! test-result-clear test-result-remove + test-result-kind test-passed? + test-log-to-file + ; Misc test-runner functions + test-runner? test-runner-reset test-runner-null + test-runner-simple test-runner-current test-runner-factory test-runner-get + test-runner-create test-runner-test-name + ;; test-runner field setter and getter functions - see %test-record-define: + test-runner-pass-count test-runner-pass-count! + test-runner-fail-count test-runner-fail-count! + test-runner-xpass-count test-runner-xpass-count! + test-runner-xfail-count test-runner-xfail-count! + test-runner-skip-count test-runner-skip-count! + test-runner-group-stack test-runner-group-stack! + test-runner-on-test-begin test-runner-on-test-begin! + test-runner-on-test-end test-runner-on-test-end! + test-runner-on-group-begin test-runner-on-group-begin! + test-runner-on-group-end test-runner-on-group-end! + test-runner-on-final test-runner-on-final! + test-runner-on-bad-count test-runner-on-bad-count! + test-runner-on-bad-end-name test-runner-on-bad-end-name! + test-result-alist test-result-alist! + test-runner-aux-value test-runner-aux-value! + ;; default/simple call-back functions, used in default test-runner, + ;; but can be called to construct more complex ones. + test-on-group-begin-simple test-on-group-end-simple + test-on-bad-count-simple test-on-bad-end-name-simple + test-on-final-simple test-on-test-end-simple + test-on-final-simple) + +(cond-expand + (srfi-9 + (define-syntax %test-record-define + (syntax-rules () + ((%test-record-define alloc runner? (name index setter getter) ...) + (define-record-type test-runner + (alloc) + runner? + (name setter getter) ...))))) + (else + (define %test-runner-cookie (list "test-runner")) + (define-syntax %test-record-define + (syntax-rules () + ((%test-record-define alloc runner? (name index getter setter) ...) + (begin + (define (runner? obj) + (and (vector? obj) + (> (vector-length obj) 1) + (eq (vector-ref obj 0) %test-runner-cookie))) + (define (alloc) + (let ((runner (make-vector 23))) + (vector-set! runner 0 %test-runner-cookie) + runner)) + (begin + (define (getter runner) + (vector-ref runner index)) ...) + (begin + (define (setter runner value) + (vector-set! runner index value)) ...))))))) + +(%test-record-define + %test-runner-alloc test-runner? + ;; Cumulate count of all tests that have passed and were expected to. + (pass-count 1 test-runner-pass-count test-runner-pass-count!) + (fail-count 2 test-runner-fail-count test-runner-fail-count!) + (xpass-count 3 test-runner-xpass-count test-runner-xpass-count!) + (xfail-count 4 test-runner-xfail-count test-runner-xfail-count!) + (skip-count 5 test-runner-skip-count test-runner-skip-count!) + (skip-list 6 %test-runner-skip-list %test-runner-skip-list!) + (fail-list 7 %test-runner-fail-list %test-runner-fail-list!) + ;; Normally #t, except when in a test-apply. + (run-list 8 %test-runner-run-list %test-runner-run-list!) + (skip-save 9 %test-runner-skip-save %test-runner-skip-save!) + (fail-save 10 %test-runner-fail-save %test-runner-fail-save!) + (group-stack 11 test-runner-group-stack test-runner-group-stack!) + (on-test-begin 12 test-runner-on-test-begin test-runner-on-test-begin!) + (on-test-end 13 test-runner-on-test-end test-runner-on-test-end!) + ;; Call-back when entering a group. Takes (runner suite-name count). + (on-group-begin 14 test-runner-on-group-begin test-runner-on-group-begin!) + ;; Call-back when leaving a group. + (on-group-end 15 test-runner-on-group-end test-runner-on-group-end!) + ;; Call-back when leaving the outermost group. + (on-final 16 test-runner-on-final test-runner-on-final!) + ;; Call-back when expected number of tests was wrong. + (on-bad-count 17 test-runner-on-bad-count test-runner-on-bad-count!) + ;; Call-back when name in test=end doesn't match test-begin. + (on-bad-end-name 18 test-runner-on-bad-end-name test-runner-on-bad-end-name!) + ;; Cumulate count of all tests that have been done. + (total-count 19 %test-runner-total-count %test-runner-total-count!) + ;; Stack (list) of (count-at-start . expected-count): + (count-list 20 %test-runner-count-list %test-runner-count-list!) + (result-alist 21 test-result-alist test-result-alist!) + ;; Field can be used by test-runner for any purpose. + ;; test-runner-simple uses it for a log file. + (aux-value 22 test-runner-aux-value test-runner-aux-value!) +) + +(define (test-runner-reset runner) + (test-result-alist! runner '()) + (test-runner-pass-count! runner 0) + (test-runner-fail-count! runner 0) + (test-runner-xpass-count! runner 0) + (test-runner-xfail-count! runner 0) + (test-runner-skip-count! runner 0) + (%test-runner-total-count! runner 0) + (%test-runner-count-list! runner '()) + (%test-runner-run-list! runner #t) + (%test-runner-skip-list! runner '()) + (%test-runner-fail-list! runner '()) + (%test-runner-skip-save! runner '()) + (%test-runner-fail-save! runner '()) + (test-runner-group-stack! runner '())) + +(define (test-runner-group-path runner) + (reverse (test-runner-group-stack runner))) + +(define (%test-null-callback runner) #f) + +(define (test-runner-null) + (let ((runner (%test-runner-alloc))) + (test-runner-reset runner) + (test-runner-on-group-begin! runner (lambda (runner name count) #f)) + (test-runner-on-group-end! runner %test-null-callback) + (test-runner-on-final! runner %test-null-callback) + (test-runner-on-test-begin! runner %test-null-callback) + (test-runner-on-test-end! runner %test-null-callback) + (test-runner-on-bad-count! runner (lambda (runner count expected) #f)) + (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f)) + runner)) + +;; Not part of the specification. FIXME +;; Controls whether a log file is generated. +(define test-log-to-file #t) + +(define (test-runner-simple) + (let ((runner (%test-runner-alloc))) + (test-runner-reset runner) + (test-runner-on-group-begin! runner test-on-group-begin-simple) + (test-runner-on-group-end! runner test-on-group-end-simple) + (test-runner-on-final! runner test-on-final-simple) + (test-runner-on-test-begin! runner test-on-test-begin-simple) + (test-runner-on-test-end! runner test-on-test-end-simple) + (test-runner-on-bad-count! runner test-on-bad-count-simple) + (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple) + runner)) + +(cond-expand + (srfi-39 + (define test-runner-current (make-parameter #f)) + (define test-runner-factory (make-parameter test-runner-simple))) + (else + (define %test-runner-current #f) + (define-syntax test-runner-current + (syntax-rules () + ((test-runner-current) + %test-runner-current) + ((test-runner-current runner) + (set! %test-runner-current runner)))) + (define %test-runner-factory test-runner-simple) + (define-syntax test-runner-factory + (syntax-rules () + ((test-runner-factory) + %test-runner-factory) + ((test-runner-factory runner) + (set! %test-runner-factory runner)))))) + +;; A safer wrapper to test-runner-current. +(define (test-runner-get) + (let ((r (test-runner-current))) + (if (not r) + (cond-expand + (srfi-23 (error "test-runner not initialized - test-begin missing?")) + (else #t))) + r)) + +(define (%test-specifier-matches spec runner) + (spec runner)) + +(define (test-runner-create) + ((test-runner-factory))) + +(define (%test-any-specifier-matches list runner) + (let ((result #f)) + (let loop ((l list)) + (cond ((null? l) result) + (else + (if (%test-specifier-matches (car l) runner) + (set! result #t)) + (loop (cdr l))))))) + +;; Returns #f, #t, or 'xfail. +(define (%test-should-execute runner) + (let ((run (%test-runner-run-list runner))) + (cond ((or + (not (or (eqv? run #t) + (%test-any-specifier-matches run runner))) + (%test-any-specifier-matches + (%test-runner-skip-list runner) + runner)) + (test-result-set! runner 'result-kind 'skip) + #f) + ((%test-any-specifier-matches + (%test-runner-fail-list runner) + runner) + (test-result-set! runner 'result-kind 'xfail) + 'xfail) + (else #t)))) + +(define (%test-begin suite-name count) + (if (not (test-runner-current)) + (test-runner-current (test-runner-create))) + (let ((runner (test-runner-current))) + ((test-runner-on-group-begin runner) runner suite-name count) + (%test-runner-skip-save! runner + (cons (%test-runner-skip-list runner) + (%test-runner-skip-save runner))) + (%test-runner-fail-save! runner + (cons (%test-runner-fail-list runner) + (%test-runner-fail-save runner))) + (%test-runner-count-list! runner + (cons (cons (%test-runner-total-count runner) + count) + (%test-runner-count-list runner))) + (test-runner-group-stack! runner (cons suite-name + (test-runner-group-stack runner))))) +(cond-expand + (kawa + ;; Kawa has test-begin built in, implemented as: + ;; (begin + ;; (cond-expand (srfi-64 #!void) (else (require 'srfi-64))) + ;; (%test-begin suite-name [count])) + ;; This puts test-begin but only test-begin in the default environment., + ;; which makes normal test suites loadable without non-portable commands. + ) + (else + (define-syntax test-begin + (syntax-rules () + ((test-begin suite-name) + (%test-begin suite-name #f)) + ((test-begin suite-name count) + (%test-begin suite-name count)))))) + +(define (test-on-group-begin-simple runner suite-name count) + (if (null? (test-runner-group-stack runner)) + (begin + (display "%%%% Starting test ") + (display suite-name) + (if test-log-to-file + (let* ((log-file-name + (if (string? test-log-to-file) test-log-to-file + (string-append suite-name ".log"))) + (log-file + (cond-expand (mzscheme + (open-output-file log-file-name 'truncate/replace)) + (else (open-output-file log-file-name))))) + (display "%%%% Starting test " log-file) + (display suite-name log-file) + (newline log-file) + (test-runner-aux-value! runner log-file) + (display " (Writing full log to \"") + (display log-file-name) + (display "\")"))) + (newline))) + (let ((log (test-runner-aux-value runner))) + (if (output-port? log) + (begin + (display "Group begin: " log) + (display suite-name log) + (newline log)))) + #f) + +(define (test-on-group-end-simple runner) + (let ((log (test-runner-aux-value runner))) + (if (output-port? log) + (begin + (display "Group end: " log) + (display (car (test-runner-group-stack runner)) log) + (newline log)))) + #f) + +(define (%test-on-bad-count-write runner count expected-count port) + (display "*** Total number of tests was " port) + (display count port) + (display " but should be " port) + (display expected-count port) + (display ". ***" port) + (newline port) + (display "*** Discrepancy indicates testsuite error or exceptions. ***" port) + (newline port)) + +(define (test-on-bad-count-simple runner count expected-count) + (%test-on-bad-count-write runner count expected-count (current-output-port)) + (let ((log (test-runner-aux-value runner))) + (if (output-port? log) + (%test-on-bad-count-write runner count expected-count log)))) + +(define (test-on-bad-end-name-simple runner begin-name end-name) + (let ((msg (string-append (%test-format-line runner) "test-end " begin-name + " does not match test-begin " end-name))) + (cond-expand + (srfi-23 (error msg)) + (else (display msg) (newline))))) + + +(define (%test-final-report1 value label port) + (if (> value 0) + (begin + (display label port) + (display value port) + (newline port)))) + +(define (%test-final-report-simple runner port) + (%test-final-report1 (test-runner-pass-count runner) + "# of expected passes " port) + (%test-final-report1 (test-runner-xfail-count runner) + "# of expected failures " port) + (%test-final-report1 (test-runner-xpass-count runner) + "# of unexpected successes " port) + (%test-final-report1 (test-runner-fail-count runner) + "# of unexpected failures " port) + (%test-final-report1 (test-runner-skip-count runner) + "# of skipped tests " port)) + +(define (test-on-final-simple runner) + (%test-final-report-simple runner (current-output-port)) + (let ((log (test-runner-aux-value runner))) + (if (output-port? log) + (%test-final-report-simple runner log)))) + +(define (%test-format-line runner) + (let* ((line-info (test-result-alist runner)) + (source-file (assq 'source-file line-info)) + (source-line (assq 'source-line line-info)) + (file (if source-file (cdr source-file) ""))) + (if source-line + (string-append file ":" + (number->string (cdr source-line)) ": ") + ""))) + +(define (%test-end suite-name line-info) + (let* ((r (test-runner-get)) + (groups (test-runner-group-stack r)) + (line (%test-format-line r))) + (test-result-alist! r line-info) + (if (null? groups) + (let ((msg (string-append line "test-end not in a group"))) + (cond-expand + (srfi-23 (error msg)) + (else (display msg) (newline))))) + (if (and suite-name (not (equal? suite-name (car groups)))) + ((test-runner-on-bad-end-name r) r suite-name (car groups))) + (let* ((count-list (%test-runner-count-list r)) + (expected-count (cdar count-list)) + (saved-count (caar count-list)) + (group-count (- (%test-runner-total-count r) saved-count))) + (if (and expected-count + (not (= expected-count group-count))) + ((test-runner-on-bad-count r) r group-count expected-count)) + ((test-runner-on-group-end r) r) + (test-runner-group-stack! r (cdr (test-runner-group-stack r))) + (%test-runner-skip-list! r (car (%test-runner-skip-save r))) + (%test-runner-skip-save! r (cdr (%test-runner-skip-save r))) + (%test-runner-fail-list! r (car (%test-runner-fail-save r))) + (%test-runner-fail-save! r (cdr (%test-runner-fail-save r))) + (%test-runner-count-list! r (cdr count-list)) + (if (null? (test-runner-group-stack r)) + ((test-runner-on-final r) r))))) + +(define-syntax test-group + (syntax-rules () + ((test-group suite-name . body) + (let ((r (test-runner-current))) + ;; Ideally should also set line-number, if available. + (test-result-alist! r (list (cons 'test-name suite-name))) + (if (%test-should-execute r) + (dynamic-wind + (lambda () (test-begin suite-name)) + (lambda () . body) + (lambda () (test-end suite-name)))))))) + +(define-syntax test-group-with-cleanup + (syntax-rules () + ((test-group-with-cleanup suite-name form cleanup-form) + (test-group suite-name + (dynamic-wind + (lambda () #f) + (lambda () form) + (lambda () cleanup-form)))) + ((test-group-with-cleanup suite-name cleanup-form) + (test-group-with-cleanup suite-name #f cleanup-form)) + ((test-group-with-cleanup suite-name form1 form2 form3 . rest) + (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest)))) + +(define (test-on-test-begin-simple runner) + (let ((log (test-runner-aux-value runner))) + (if (output-port? log) + (let* ((results (test-result-alist runner)) + (source-file (assq 'source-file results)) + (source-line (assq 'source-line results)) + (source-form (assq 'source-form results)) + (test-name (assq 'test-name results))) + (display "Test begin:" log) + (newline log) + (if test-name (%test-write-result1 test-name log)) + (if source-file (%test-write-result1 source-file log)) + (if source-line (%test-write-result1 source-line log)) + (if source-form (%test-write-result1 source-form log)))))) + +(define-syntax test-result-ref + (syntax-rules () + ((test-result-ref runner pname) + (test-result-ref runner pname #f)) + ((test-result-ref runner pname default) + (let ((p (assq pname (test-result-alist runner)))) + (if p (cdr p) default))))) + +(define (test-on-test-end-simple runner) + (let ((log (test-runner-aux-value runner)) + (kind (test-result-ref runner 'result-kind))) + (if (memq kind '(fail xpass)) + (let* ((results (test-result-alist runner)) + (source-file (assq 'source-file results)) + (source-line (assq 'source-line results)) + (test-name (assq 'test-name results))) + (if (or source-file source-line) + (begin + (if source-file (display (cdr source-file))) + (display ":") + (if source-line (display (cdr source-line))) + (display ": "))) + (display (if (eq? kind 'xpass) "XPASS" "FAIL")) + (if test-name + (begin + (display " ") + (display (cdr test-name)))) + (newline))) + (if (output-port? log) + (begin + (display "Test end:" log) + (newline log) + (let loop ((list (test-result-alist runner))) + (if (pair? list) + (let ((pair (car list))) + ;; Write out properties not written out by on-test-begin. + (if (not (memq (car pair) + '(test-name source-file source-line source-form))) + (%test-write-result1 pair log)) + (loop (cdr list))))))))) + +(define (%test-write-result1 pair port) + (display " " port) + (display (car pair) port) + (display ": " port) + (write (cdr pair) port) + (newline port)) + +(define (test-result-set! runner pname value) + (let* ((alist (test-result-alist runner)) + (p (assq pname alist))) + (if p + (set-cdr! p value) + (test-result-alist! runner (cons (cons pname value) alist))))) + +(define (test-result-clear runner) + (test-result-alist! runner '())) + +(define (test-result-remove runner pname) + (let* ((alist (test-result-alist runner)) + (p (assq pname alist))) + (if p + (test-result-alist! runner + (let loop ((r alist)) + (if (eq? r p) (cdr r) + (cons (car r) (loop (cdr r))))))))) + +(define (test-result-kind . rest) + (let ((runner (if (pair? rest) (car rest) (test-runner-current)))) + (test-result-ref runner 'result-kind))) + +(define (test-passed? . rest) + (let ((runner (if (pair? rest) (car rest) (test-runner-get)))) + (memq (test-result-ref runner 'result-kind) '(pass xpass)))) + +(define (%test-report-result) + (let* ((r (test-runner-get)) + (result-kind (test-result-kind r))) + (case result-kind + ((pass) + (test-runner-pass-count! r (+ 1 (test-runner-pass-count r)))) + ((fail) + (test-runner-fail-count! r (+ 1 (test-runner-fail-count r)))) + ((xpass) + (test-runner-xpass-count! r (+ 1 (test-runner-xpass-count r)))) + ((xfail) + (test-runner-xfail-count! r (+ 1 (test-runner-xfail-count r)))) + (else + (test-runner-skip-count! r (+ 1 (test-runner-skip-count r))))) + (%test-runner-total-count! r (+ 1 (%test-runner-total-count r))) + ((test-runner-on-test-end r) r))) + +(cond-expand + (guile + (define-syntax %test-evaluate-with-catch + (syntax-rules () + ((%test-evaluate-with-catch test-expression) + (catch #t + (lambda () test-expression) + (lambda (key . args) + (test-result-set! (test-runner-current) 'actual-error + (cons key args)) + #f)))))) + (kawa + (define-syntax %test-evaluate-with-catch + (syntax-rules () + ((%test-evaluate-with-catch test-expression) + (try-catch test-expression + (ex + (test-result-set! (test-runner-current) 'actual-error ex) + #f)))))) + (srfi-34 + (define-syntax %test-evaluate-with-catch + (syntax-rules () + ((%test-evaluate-with-catch test-expression) + (guard (err (else #f)) test-expression))))) + (chicken + (define-syntax %test-evaluate-with-catch + (syntax-rules () + ((%test-evaluate-with-catch test-expression) + (condition-case test-expression (ex () #f)))))) + (else + (define-syntax %test-evaluate-with-catch + (syntax-rules () + ((%test-evaluate-with-catch test-expression) + test-expression))))) + +(cond-expand + ((or kawa mzscheme) + (cond-expand + (mzscheme + (define-for-syntax (%test-syntax-file form) + (let ((source (syntax-source form))) + (cond ((string? source) file) + ((path? source) (path->string source)) + (else #f))))) + (kawa + (define (%test-syntax-file form) + (syntax-source form)))) + (define (%test-source-line2 form) + (let* ((line (syntax-line form)) + (file (%test-syntax-file form)) + (line-pair (if line (list (cons 'source-line line)) '()))) + (cons (cons 'source-form (syntax-object->datum form)) + (if file (cons (cons 'source-file file) line-pair) line-pair))))) + (guile-2 + (define (%test-source-line2 form) + (let* ((src-props (syntax-source form)) + (file (and src-props (assq-ref src-props 'filename))) + (line (and src-props (assq-ref src-props 'line))) + (file-alist (if file + `((source-file . ,file)) + '())) + (line-alist (if line + `((source-line . ,(+ line 1))) + '()))) + (datum->syntax (syntax here) + `((source-form . ,(syntax->datum form)) + ,@file-alist + ,@line-alist))))) + (else + (define (%test-source-line2 form) + '()))) + +(define (%test-on-test-begin r) + (%test-should-execute r) + ((test-runner-on-test-begin r) r) + (not (eq? 'skip (test-result-ref r 'result-kind)))) + +(define (%test-on-test-end r result) + (test-result-set! r 'result-kind + (if (eq? (test-result-ref r 'result-kind) 'xfail) + (if result 'xpass 'xfail) + (if result 'pass 'fail)))) + +(define (test-runner-test-name runner) + (test-result-ref runner 'test-name "")) + +(define-syntax %test-comp2body + (syntax-rules () + ((%test-comp2body r comp expected expr) + (let () + (if (%test-on-test-begin r) + (let ((exp expected)) + (test-result-set! r 'expected-value exp) + (let ((res (%test-evaluate-with-catch expr))) + (test-result-set! r 'actual-value res) + (%test-on-test-end r (comp exp res))))) + (%test-report-result))))) + +(define (%test-approximate= error) + (lambda (value expected) + (let ((rval (real-part value)) + (ival (imag-part value)) + (rexp (real-part expected)) + (iexp (imag-part expected))) + (and (>= rval (- rexp error)) + (>= ival (- iexp error)) + (<= rval (+ rexp error)) + (<= ival (+ iexp error)))))) + +(define-syntax %test-comp1body + (syntax-rules () + ((%test-comp1body r expr) + (let () + (if (%test-on-test-begin r) + (let () + (let ((res (%test-evaluate-with-catch expr))) + (test-result-set! r 'actual-value res) + (%test-on-test-end r res)))) + (%test-report-result))))) + +(cond-expand + ((or kawa mzscheme guile-2) + ;; Should be made to work for any Scheme with syntax-case + ;; However, I haven't gotten the quoting working. FIXME. + (define-syntax test-end + (lambda (x) + (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () + (((mac suite-name) line) + (syntax + (%test-end suite-name line))) + (((mac) line) + (syntax + (%test-end #f line)))))) + (define-syntax test-assert + (lambda (x) + (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () + (((mac tname expr) line) + (syntax + (let* ((r (test-runner-get)) + (name tname)) + (test-result-alist! r (cons (cons 'test-name tname) line)) + (%test-comp1body r expr)))) + (((mac expr) line) + (syntax + (let* ((r (test-runner-get))) + (test-result-alist! r line) + (%test-comp1body r expr))))))) + (define (%test-comp2 comp x) + (syntax-case (list x (list (syntax quote) (%test-source-line2 x)) comp) () + (((mac tname expected expr) line comp) + (syntax + (let* ((r (test-runner-get)) + (name tname)) + (test-result-alist! r (cons (cons 'test-name tname) line)) + (%test-comp2body r comp expected expr)))) + (((mac expected expr) line comp) + (syntax + (let* ((r (test-runner-get))) + (test-result-alist! r line) + (%test-comp2body r comp expected expr)))))) + (define-syntax test-eqv + (lambda (x) (%test-comp2 (syntax eqv?) x))) + (define-syntax test-eq + (lambda (x) (%test-comp2 (syntax eq?) x))) + (define-syntax test-equal + (lambda (x) (%test-comp2 (syntax equal?) x))) + (define-syntax test-approximate ;; FIXME - needed for non-Kawa + (lambda (x) + (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () + (((mac tname expected expr error) line) + (syntax + (let* ((r (test-runner-get)) + (name tname)) + (test-result-alist! r (cons (cons 'test-name tname) line)) + (%test-comp2body r (%test-approximate= error) expected expr)))) + (((mac expected expr error) line) + (syntax + (let* ((r (test-runner-get))) + (test-result-alist! r line) + (%test-comp2body r (%test-approximate= error) expected expr)))))))) + (else + (define-syntax test-end + (syntax-rules () + ((test-end) + (%test-end #f '())) + ((test-end suite-name) + (%test-end suite-name '())))) + (define-syntax test-assert + (syntax-rules () + ((test-assert tname test-expression) + (let* ((r (test-runner-get)) + (name tname)) + (test-result-alist! r '((test-name . tname))) + (%test-comp1body r test-expression))) + ((test-assert test-expression) + (let* ((r (test-runner-get))) + (test-result-alist! r '()) + (%test-comp1body r test-expression))))) + (define-syntax %test-comp2 + (syntax-rules () + ((%test-comp2 comp tname expected expr) + (let* ((r (test-runner-get)) + (name tname)) + (test-result-alist! r (list (cons 'test-name tname))) + (%test-comp2body r comp expected expr))) + ((%test-comp2 comp expected expr) + (let* ((r (test-runner-get))) + (test-result-alist! r '()) + (%test-comp2body r comp expected expr))))) + (define-syntax test-equal + (syntax-rules () + ((test-equal . rest) + (%test-comp2 equal? . rest)))) + (define-syntax test-eqv + (syntax-rules () + ((test-eqv . rest) + (%test-comp2 eqv? . rest)))) + (define-syntax test-eq + (syntax-rules () + ((test-eq . rest) + (%test-comp2 eq? . rest)))) + (define-syntax test-approximate + (syntax-rules () + ((test-approximate tname expected expr error) + (%test-comp2 (%test-approximate= error) tname expected expr)) + ((test-approximate expected expr error) + (%test-comp2 (%test-approximate= error) expected expr)))))) + +(cond-expand + (guile + (define-syntax %test-error + (syntax-rules () + ((%test-error r etype expr) + (cond ((%test-on-test-begin r) + (let ((et etype)) + (test-result-set! r 'expected-error et) + (%test-on-test-end r + (catch #t + (lambda () + (test-result-set! r 'actual-value expr) + #f) + (lambda (key . args) + ;; TODO: decide how to specify expected + ;; error types for Guile. + (test-result-set! r 'actual-error + (cons key args)) + #t))) + (%test-report-result)))))))) + (mzscheme + (define-syntax %test-error + (syntax-rules () + ((%test-error r etype expr) + (%test-comp1body r (with-handlers (((lambda (h) #t) (lambda (h) #t))) + (let () + (test-result-set! r 'actual-value expr) + #f))))))) + (chicken + (define-syntax %test-error + (syntax-rules () + ((%test-error r etype expr) + (%test-comp1body r (condition-case expr (ex () #t))))))) + (kawa + (define-syntax %test-error + (syntax-rules () + ((%test-error r #t expr) + (cond ((%test-on-test-begin r) + (test-result-set! r 'expected-error #t) + (%test-on-test-end r + (try-catch + (let () + (test-result-set! r 'actual-value expr) + #f) + (ex + (test-result-set! r 'actual-error ex) + #t))) + (%test-report-result)))) + ((%test-error r etype expr) + (if (%test-on-test-begin r) + (let ((et etype)) + (test-result-set! r 'expected-error et) + (%test-on-test-end r + (try-catch + (let () + (test-result-set! r 'actual-value expr) + #f) + (ex + (test-result-set! r 'actual-error ex) + (cond ((and (instance? et ) + (gnu.bytecode.ClassType:isSubclass et )) + (instance? ex et)) + (else #t))))) + (%test-report-result))))))) + ((and srfi-34 srfi-35) + (define-syntax %test-error + (syntax-rules () + ((%test-error r etype expr) + (%test-comp1body r (guard (ex ((condition-type? etype) + (and (condition? ex) (condition-has-type? ex etype))) + ((procedure? etype) + (etype ex)) + ((equal? etype #t) + #t) + (else #t)) + expr #f)))))) + (srfi-34 + (define-syntax %test-error + (syntax-rules () + ((%test-error r etype expr) + (%test-comp1body r (guard (ex (else #t)) expr #f)))))) + (else + (define-syntax %test-error + (syntax-rules () + ((%test-error r etype expr) + (begin + ((test-runner-on-test-begin r) r) + (test-result-set! r 'result-kind 'skip) + (%test-report-result))))))) + +(cond-expand + ((or kawa mzscheme guile-2) + + (define-syntax test-error + (lambda (x) + (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () + (((mac tname etype expr) line) + (syntax + (let* ((r (test-runner-get)) + (name tname)) + (test-result-alist! r (cons (cons 'test-name tname) line)) + (%test-error r etype expr)))) + (((mac etype expr) line) + (syntax + (let* ((r (test-runner-get))) + (test-result-alist! r line) + (%test-error r etype expr)))) + (((mac expr) line) + (syntax + (let* ((r (test-runner-get))) + (test-result-alist! r line) + (%test-error r #t expr)))))))) + (else + (define-syntax test-error + (syntax-rules () + ((test-error name etype expr) + (let ((r (test-runner-get))) + (test-result-alist! r `((test-name . ,name))) + (%test-error r etype expr))) + ((test-error etype expr) + (let ((r (test-runner-get))) + (test-result-alist! r '()) + (%test-error r etype expr))) + ((test-error expr) + (let ((r (test-runner-get))) + (test-result-alist! r '()) + (%test-error r #t expr))))))) + +(define (test-apply first . rest) + (if (test-runner? first) + (test-with-runner first (apply test-apply rest)) + (let ((r (test-runner-current))) + (if r + (let ((run-list (%test-runner-run-list r))) + (cond ((null? rest) + (%test-runner-run-list! r (reverse run-list)) + (first)) ;; actually apply procedure thunk + (else + (%test-runner-run-list! + r + (if (eq? run-list #t) (list first) (cons first run-list))) + (apply test-apply rest) + (%test-runner-run-list! r run-list)))) + (let ((r (test-runner-create))) + (test-with-runner r (apply test-apply first rest)) + ((test-runner-on-final r) r)))))) + +(define-syntax test-with-runner + (syntax-rules () + ((test-with-runner runner form ...) + (let ((saved-runner (test-runner-current))) + (dynamic-wind + (lambda () (test-runner-current runner)) + (lambda () form ...) + (lambda () (test-runner-current saved-runner))))))) + +;;; Predicates + +(define (%test-match-nth n count) + (let ((i 0)) + (lambda (runner) + (set! i (+ i 1)) + (and (>= i n) (< i (+ n count)))))) + +(define-syntax test-match-nth + (syntax-rules () + ((test-match-nth n) + (test-match-nth n 1)) + ((test-match-nth n count) + (%test-match-nth n count)))) + +(define (%test-match-all . pred-list) + (lambda (runner) + (let ((result #t)) + (let loop ((l pred-list)) + (if (null? l) + result + (begin + (if (not ((car l) runner)) + (set! result #f)) + (loop (cdr l)))))))) + +(define-syntax test-match-all + (syntax-rules () + ((test-match-all pred ...) + (%test-match-all (%test-as-specifier pred) ...)))) + +(define (%test-match-any . pred-list) + (lambda (runner) + (let ((result #f)) + (let loop ((l pred-list)) + (if (null? l) + result + (begin + (if ((car l) runner) + (set! result #t)) + (loop (cdr l)))))))) + +(define-syntax test-match-any + (syntax-rules () + ((test-match-any pred ...) + (%test-match-any (%test-as-specifier pred) ...)))) + +;; Coerce to a predicate function: +(define (%test-as-specifier specifier) + (cond ((procedure? specifier) specifier) + ((integer? specifier) (test-match-nth 1 specifier)) + ((string? specifier) (test-match-name specifier)) + (else + (error "not a valid test specifier")))) + +(define-syntax test-skip + (syntax-rules () + ((test-skip pred ...) + (let ((runner (test-runner-get))) + (%test-runner-skip-list! runner + (cons (test-match-all (%test-as-specifier pred) ...) + (%test-runner-skip-list runner))))))) + +(define-syntax test-expect-fail + (syntax-rules () + ((test-expect-fail pred ...) + (let ((runner (test-runner-get))) + (%test-runner-fail-list! runner + (cons (test-match-all (%test-as-specifier pred) ...) + (%test-runner-fail-list runner))))))) + +(define (test-match-name name) + (lambda (runner) + (equal? name (test-runner-test-name runner)))) + +(define (test-read-eval-string string) + (let* ((port (open-input-string string)) + (form (read port))) + (if (eof-object? (read-char port)) + (cond-expand + (guile (eval form (current-module))) + (else (eval form))) + (cond-expand + (srfi-23 (error "(not at eof)")) + (else "error"))))) + diff --git a/test-suite/Makefile.am b/test-suite/Makefile.am index 5ce79dc53..6df982691 100644 --- a/test-suite/Makefile.am +++ b/test-suite/Makefile.am @@ -137,8 +137,10 @@ 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-64.test \ tests/srfi-67.test \ tests/srfi-69.test \ tests/srfi-88.test \ @@ -177,7 +179,8 @@ EXTRA_DIST = \ guile-test \ test-suite/lib.scm \ $(SCM_TESTS) \ - tests/rnrs-test-a.scm + tests/rnrs-test-a.scm \ + tests/srfi-64-test.scm \ ChangeLog-2008 diff --git a/test-suite/tests/srfi-43.test b/test-suite/tests/srfi-43.test new file mode 100644 index 000000000..554843e75 --- /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: diff --git a/test-suite/tests/srfi-64-test.scm b/test-suite/tests/srfi-64-test.scm new file mode 100644 index 000000000..3cd67d0ef --- /dev/null +++ b/test-suite/tests/srfi-64-test.scm @@ -0,0 +1,934 @@ +;;; +;;; This is a test suite written in the notation of +;;; SRFI-64, A Scheme API for test suites +;;; + +(test-begin "SRFI 64 - Meta-Test Suite") + +;;; +;;; Ironically, in order to set up the meta-test environment, +;;; we have to invoke one of the most sophisticated features: +;;; custom test runners +;;; + +;;; The `prop-runner' invokes `thunk' in the context of a new +;;; test runner, and returns the indicated properties of the +;;; last-executed test result. + +(define (prop-runner props thunk) + (let ((r (test-runner-null)) + (plist '())) + ;; + (test-runner-on-test-end! + r + (lambda (runner) + (set! plist (test-result-alist runner)))) + ;; + (test-with-runner r (thunk)) + ;; reorder the properties so they are in the order + ;; given by `props'. Note that any property listed in `props' + ;; that is not in the property alist will occur as #f + (map (lambda (k) + (assq k plist)) + props))) + +;;; `on-test-runner' creates a null test runner and then +;;; arranged for `visit' to be called with the runner +;;; whenever a test is run. The results of the calls to +;;; `visit' are returned in a list + +(define (on-test-runner thunk visit) + (let ((r (test-runner-null)) + (results '())) + ;; + (test-runner-on-test-end! + r + (lambda (runner) + (set! results (cons (visit r) results)))) + ;; + (test-with-runner r (thunk)) + (reverse results))) + +;;; +;;; The `triv-runner' invokes `thunk' +;;; and returns a list of 6 lists, the first 5 of which +;;; are a list of the names of the tests that, respectively, +;;; PASS, FAIL, XFAIL, XPASS, and SKIP. +;;; The last item is a list of counts. +;;; + +(define (triv-runner thunk) + (let ((r (test-runner-null)) + (accum-pass '()) + (accum-fail '()) + (accum-xfail '()) + (accum-xpass '()) + (accum-skip '())) + ;; + (test-runner-on-bad-count! + r + (lambda (runner count expected-count) + (error (string-append "bad count " (number->string count) + " but expected " + (number->string expected-count))))) + (test-runner-on-bad-end-name! + r + (lambda (runner begin end) + (error (string-append "bad end group name " end + " but expected " begin)))) + (test-runner-on-test-end! + r + (lambda (runner) + (let ((n (test-runner-test-name runner))) + (case (test-result-kind runner) + ((pass) (set! accum-pass (cons n accum-pass))) + ((fail) (set! accum-fail (cons n accum-fail))) + ((xpass) (set! accum-xpass (cons n accum-xpass))) + ((xfail) (set! accum-xfail (cons n accum-xfail))) + ((skip) (set! accum-skip (cons n accum-skip))))))) + ;; + (test-with-runner r (thunk)) + (list (reverse accum-pass) ; passed as expected + (reverse accum-fail) ; failed, but was expected to pass + (reverse accum-xfail) ; failed as expected + (reverse accum-xpass) ; passed, but was expected to fail + (reverse accum-skip) ; was not executed + (list (test-runner-pass-count r) + (test-runner-fail-count r) + (test-runner-xfail-count r) + (test-runner-xpass-count r) + (test-runner-skip-count r))))) + +(define (path-revealing-runner thunk) + (let ((r (test-runner-null)) + (seq '())) + ;; + (test-runner-on-test-end! + r + (lambda (runner) + (set! seq (cons (list (test-runner-group-path runner) + (test-runner-test-name runner)) + seq)))) + (test-with-runner r (thunk)) + (reverse seq))) + +;;; +;;; Now we can start testing compliance with SRFI-64 +;;; + +(test-begin "1. Simple test-cases") + +(test-begin "1.1. test-assert") + +(define (t) + (triv-runner + (lambda () + (test-assert "a" #t) + (test-assert "b" #f)))) + +(test-equal + "1.1.1. Very simple" + '(("a") ("b") () () () (1 1 0 0 0)) + (t)) + +(test-equal + "1.1.2. A test with no name" + '(("a") ("") () () () (1 1 0 0 0)) + (triv-runner (lambda () (test-assert "a" #t) (test-assert #f)))) + +(test-equal + "1.1.3. Tests can have the same name" + '(("a" "a") () () () () (2 0 0 0 0)) + (triv-runner (lambda () (test-assert "a" #t) (test-assert "a" #t)))) + +(define (choke) + (vector-ref '#(1 2) 3)) + +(test-equal + "1.1.4. One way to FAIL is to throw an error" + '(() ("a") () () () (0 1 0 0 0)) + (triv-runner (lambda () (test-assert "a" (choke))))) + +(test-end);1.1 + +(test-begin "1.2. test-eqv") + +(define (mean x y) + (/ (+ x y) 2.0)) + +(test-equal + "1.2.1. Simple numerical equivalence" + '(("c") ("a" "b") () () () (1 2 0 0 0)) + (triv-runner + (lambda () + (test-eqv "a" (mean 3 5) 4) + (test-eqv "b" (mean 3 5) 4.5) + (test-eqv "c" (mean 3 5) 4.0)))) + +(test-end);1.2 + +(test-end "1. Simple test-cases") + +;;; +;;; +;;; + +(test-begin "2. Tests for catching errors") + +(test-begin "2.1. test-error") + +(test-equal + "2.1.1. Baseline test; PASS with no optional args" + '(("") () () () () (1 0 0 0 0)) + (triv-runner + (lambda () + ;; PASS + (test-error (vector-ref '#(1 2) 9))))) + +(test-equal + "2.1.2. Baseline test; FAIL with no optional args" + '(() ("") () () () (0 1 0 0 0)) + (triv-runner + (lambda () + ;; FAIL: the expr does not raise an error and `test-error' is + ;; claiming that it will, so this test should FAIL + (test-error (vector-ref '#(1 2) 0))))) + +(test-equal + "2.1.3. PASS with a test name and error type" + '(("a") () () () () (1 0 0 0 0)) + (triv-runner + (lambda () + ;; PASS + (test-error "a" #t (vector-ref '#(1 2) 9))))) + +(test-end "2.1. test-error") + +(test-end "2. Tests for catching errors") + +;;; +;;; +;;; + +(test-begin "3. Test groups and paths") + +(test-equal + "3.1. test-begin with unspecific test-end" + '(("b") () () () () (1 0 0 0 0)) + (triv-runner + (lambda () + (test-begin "a") + (test-assert "b" #t) + (test-end)))) + +(test-equal + "3.2. test-begin with name-matching test-end" + '(("b") () () () () (1 0 0 0 0)) + (triv-runner + (lambda () + (test-begin "a") + (test-assert "b" #t) + (test-end "a")))) + +;;; since the error raised by `test-end' on a mismatch is not a test +;;; error, we actually expect the triv-runner itself to fail + +(test-error + "3.3. test-begin with mismatched test-end" +#t + (triv-runner + (lambda () + (test-begin "a") + (test-assert "b" #t) + (test-end "x")))) + +(test-equal + "3.4. test-begin with name and count" + '(("b" "c") () () () () (2 0 0 0 0)) + (triv-runner + (lambda () + (test-begin "a" 2) + (test-assert "b" #t) + (test-assert "c" #t) + (test-end "a")))) + +;; similarly here, a mismatched count is a lexical error +;; and not a test failure... + +(test-error + "3.5. test-begin with mismatched count" + #t + (triv-runner + (lambda () + (test-begin "a" 99) + (test-assert "b" #t) + (test-end "a")))) + +(test-equal + "3.6. introspecting on the group path" + '((() "w") + (("a" "b") "x") + (("a" "b") "y") + (("a") "z")) + ;; + ;; `path-revealing-runner' is designed to return a list + ;; of the tests executed, in order. Each entry is a list + ;; (GROUP-PATH TEST-NAME), and each GROUP-PATH is a list + ;; of test groups starting from the topmost + ;; + (path-revealing-runner + (lambda () + (test-assert "w" #t) + (test-begin "a") + (test-begin "b") + (test-assert "x" #t) + (test-assert "y" #t) + (test-end) + (test-assert "z" #t)))) + + +(test-end "3. Test groups and paths") + +;;; +;;; +;;; + +(test-begin "4. Handling set-up and cleanup") + +(test-equal "4.1. Normal exit path" + '(in 1 2 out) + (let ((ex '())) + (define (do s) + (set! ex (cons s ex))) + ;; + (triv-runner + (lambda () + (test-group-with-cleanup + "foo" + (do 'in) + (do 1) + (do 2) + (do 'out)))) + (reverse ex))) + +(test-equal "4.2. Exception exit path" + '(in 1 out) + (let ((ex '())) + (define (do s) + (set! ex (cons s ex))) + ;; + ;; the outer runner is to run the `test-error' in, to + ;; catch the exception raised in the inner runner, + ;; since we don't want to depend on any other + ;; exception-catching support + ;; + (triv-runner + (lambda () + (test-error + (triv-runner + (lambda () + (test-group-with-cleanup + "foo" + (do 'in) (test-assert #t) + (do 1) (test-assert #t) + (choke) (test-assert #t) + (do 2) (test-assert #t) + (do 'out))))))) + (reverse ex))) + +(test-end "4. Handling set-up and cleanup") + +;;; +;;; +;;; + +(test-begin "5. Test specifiers") + +(test-begin "5.1. test-match-named") + +(test-equal "5.1.1. match test names" + '(("y") () () () ("x") (1 0 0 0 1)) + (triv-runner + (lambda () + (test-skip (test-match-name "x")) + (test-assert "x" #t) + (test-assert "y" #t)))) + +(test-equal "5.1.2. but not group names" + '(("z") () () () () (1 0 0 0 0)) + (triv-runner + (lambda () + (test-skip (test-match-name "x")) + (test-begin "x") + (test-assert "z" #t) + (test-end)))) + +(test-end) + +(test-begin "5.2. test-match-nth") +;; See also: [6.4. Short-circuit evaluation] + +(test-equal "5.2.1. skip the nth one after" + '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1)) + (triv-runner + (lambda () + (test-assert "v" #t) + (test-skip (test-match-nth 2)) + (test-assert "w" #t) ; 1 + (test-assert "x" #t) ; 2 SKIP + (test-assert "y" #t) ; 3 + (test-assert "z" #t)))) ; 4 + +(test-equal "5.2.2. skip m, starting at n" + '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2)) + (triv-runner + (lambda () + (test-assert "v" #t) + (test-skip (test-match-nth 2 2)) + (test-assert "w" #t) ; 1 + (test-assert "x" #t) ; 2 SKIP + (test-assert "y" #t) ; 3 SKIP + (test-assert "z" #t)))) ; 4 + +(test-end) + +(test-begin "5.3. test-match-any") +(test-equal "5.3.1. basic disjunction" + '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2)) + (triv-runner + (lambda () + (test-assert "v" #t) + (test-skip (test-match-any (test-match-nth 3) + (test-match-name "x"))) + (test-assert "w" #t) ; 1 + (test-assert "x" #t) ; 2 SKIP(NAME) + (test-assert "y" #t) ; 3 SKIP(COUNT) + (test-assert "z" #t)))) ; 4 + +(test-equal "5.3.2. disjunction is commutative" + '(("v" "w" "z") () () () ("x" "y") (3 0 0 0 2)) + (triv-runner + (lambda () + (test-assert "v" #t) + (test-skip (test-match-any (test-match-name "x") + (test-match-nth 3))) + (test-assert "w" #t) ; 1 + (test-assert "x" #t) ; 2 SKIP(NAME) + (test-assert "y" #t) ; 3 SKIP(COUNT) + (test-assert "z" #t)))) ; 4 + +(test-end) + +(test-begin "5.4. test-match-all") +(test-equal "5.4.1. basic conjunction" + '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1)) + (triv-runner + (lambda () + (test-assert "v" #t) + (test-skip (test-match-all (test-match-nth 2 2) + (test-match-name "x"))) + (test-assert "w" #t) ; 1 + (test-assert "x" #t) ; 2 SKIP(NAME) & SKIP(COUNT) + (test-assert "y" #t) ; 3 SKIP(COUNT) + (test-assert "z" #t)))) ; 4 + +(test-equal "5.4.2. conjunction is commutative" + '(("v" "w" "y" "z") () () () ("x") (4 0 0 0 1)) + (triv-runner + (lambda () + (test-assert "v" #t) + (test-skip (test-match-all (test-match-name "x") + (test-match-nth 2 2))) + (test-assert "w" #t) ; 1 + (test-assert "x" #t) ; 2 SKIP(NAME) & SKIP(COUNT) + (test-assert "y" #t) ; 3 SKIP(COUNT) + (test-assert "z" #t)))) ; 4 + +(test-end) + +(test-end "5. Test specifiers") + +;;; +;;; +;;; + +(test-begin "6. Skipping selected tests") + +(test-equal + "6.1. Skip by specifier - match-name" + '(("x") () () () ("y") (1 0 0 0 1)) + (triv-runner + (lambda () + (test-begin "a") + (test-skip (test-match-name "y")) + (test-assert "x" #t) ; PASS + (test-assert "y" #f) ; SKIP + (test-end)))) + +(test-equal + "6.2. Shorthand specifiers" + '(("x") () () () ("y") (1 0 0 0 1)) + (triv-runner + (lambda () + (test-begin "a") + (test-skip "y") + (test-assert "x" #t) ; PASS + (test-assert "y" #f) ; SKIP + (test-end)))) + +(test-begin "6.3. Specifier Stack") + +(test-equal + "6.3.1. Clearing the Specifier Stack" + '(("x" "x") ("y") () () ("y") (2 1 0 0 1)) + (triv-runner + (lambda () + (test-begin "a") + (test-skip "y") + (test-assert "x" #t) ; PASS + (test-assert "y" #f) ; SKIP + (test-end) + (test-begin "b") + (test-assert "x" #t) ; PASS + (test-assert "y" #f) ; FAIL + (test-end)))) + +(test-equal + "6.3.2. Inheriting the Specifier Stack" + '(("x" "x") () () () ("y" "y") (2 0 0 0 2)) + (triv-runner + (lambda () + (test-skip "y") + (test-begin "a") + (test-assert "x" #t) ; PASS + (test-assert "y" #f) ; SKIP + (test-end) + (test-begin "b") + (test-assert "x" #t) ; PASS + (test-assert "y" #f) ; SKIP + (test-end)))) + +(test-end);6.3 + +(test-begin "6.4. Short-circuit evaluation") + +(test-equal + "6.4.1. In test-match-all" + '(("x") ("y" "x" "z") () () ("y") (1 3 0 0 1)) + (triv-runner + (lambda () + (test-begin "a") + (test-skip (test-match-all "y" (test-match-nth 2))) + ;; let's label the substructure forms so we can + ;; see which one `test-match-nth' is going to skip + ;; ; # "y" 2 result + (test-assert "x" #t) ; 1 - #f #f PASS + (test-assert "y" #f) ; 2 - #t #t SKIP + (test-assert "y" #f) ; 3 - #t #f FAIL + (test-assert "x" #f) ; 4 - #f #f FAIL + (test-assert "z" #f) ; 5 - #f #f FAIL + (test-end)))) + +(test-equal + "6.4.2. In separate skip-list entries" + '(("x") ("x" "z") () () ("y" "y") (1 2 0 0 2)) + (triv-runner + (lambda () + (test-begin "a") + (test-skip "y") + (test-skip (test-match-nth 2)) + ;; let's label the substructure forms so we can + ;; see which one `test-match-nth' is going to skip + ;; ; # "y" 2 result + (test-assert "x" #t) ; 1 - #f #f PASS + (test-assert "y" #f) ; 2 - #t #t SKIP + (test-assert "y" #f) ; 3 - #t #f SKIP + (test-assert "x" #f) ; 4 - #f #f FAIL + (test-assert "z" #f) ; 5 - #f #f FAIL + (test-end)))) + +(test-begin "6.4.3. Skipping test suites") + +(test-equal + "6.4.3.1. Introduced using 'test-begin'" + '(("x") () () () () (1 0 0 0 0)) + (triv-runner + (lambda () + (test-begin "a") + (test-skip "b") + (test-begin "b") ; not skipped + (test-assert "x" #t) + (test-end "b") + (test-end "a")))) + +(test-expect-fail 1) ;; ??? +(test-equal + "6.4.3.2. Introduced using 'test-group'" + '(() () () () () (0 0 0 0 1)) + (triv-runner + (lambda () + (test-begin "a") + (test-skip "b") + (test-group + "b" ; skipped + (test-assert "x" #t)) + (test-end "a")))) + +(test-equal + "6.4.3.3. Non-skipped 'test-group'" + '(("x") () () () () (1 0 0 0 0)) + (triv-runner + (lambda () + (test-begin "a") + (test-skip "c") + (test-group "b" (test-assert "x" #t)) + (test-end "a")))) + +(test-end) ; 6.4.3 + +(test-end);6.4 + +(test-end "6. Skipping selected tests") + +;;; +;;; +;;; + +(test-begin "7. Expected failures") + +(test-equal "7.1. Simple example" + '(() ("x") ("z") () () (0 1 1 0 0)) + (triv-runner + (lambda () + (test-assert "x" #f) + (test-expect-fail "z") + (test-assert "z" #f)))) + +(test-equal "7.2. Expected exception" + '(() ("x") ("z") () () (0 1 1 0 0)) + (triv-runner + (lambda () + (test-assert "x" #f) + (test-expect-fail "z") + (test-assert "z" (choke))))) + +(test-equal "7.3. Unexpectedly PASS" + '(() () ("y") ("x") () (0 0 1 1 0)) + (triv-runner + (lambda () + (test-expect-fail "x") + (test-expect-fail "y") + (test-assert "x" #t) + (test-assert "y" #f)))) + + + +(test-end "7. Expected failures") + +;;; +;;; +;;; + +(test-begin "8. Test-runner") + +;;; +;;; Because we want this test suite to be accurate even +;;; when the underlying implementation chooses to use, e.g., +;;; a global variable to implement what could be thread variables +;;; or SRFI-39 parameter objects, we really need to save and restore +;;; their state ourselves +;;; +(define (with-factory-saved thunk) + (let* ((saved (test-runner-factory)) + (result (thunk))) + (test-runner-factory saved) + result)) + +(test-begin "8.1. test-runner-current") +(test-assert "8.1.1. automatically restored" + (let ((a 0) + (b 1) + (c 2)) + ; + (triv-runner + (lambda () + (set! a (test-runner-current)) + ;; + (triv-runner + (lambda () + (set! b (test-runner-current)))) + ;; + (set! c (test-runner-current)))) + ;; + (and (eq? a c) + (not (eq? a b))))) + +(test-end) + +(test-begin "8.2. test-runner-simple") +(test-assert "8.2.1. default on-test hook" + (eq? (test-runner-on-test-end (test-runner-simple)) + test-on-test-end-simple)) +(test-assert "8.2.2. default on-final hook" + (eq? (test-runner-on-final (test-runner-simple)) + test-on-final-simple)) +(test-end) + +(test-begin "8.3. test-runner-factory") + +(test-assert "8.3.1. default factory" + (eq? (test-runner-factory) test-runner-simple)) + +(test-assert "8.3.2. settable factory" + (with-factory-saved + (lambda () + (test-runner-factory test-runner-null) + ;; we have no way, without bringing in other SRFIs, + ;; to make sure the following doesn't print anything, + ;; but it shouldn't: + (test-with-runner + (test-runner-create) + (lambda () + (test-begin "a") + (test-assert #t) ; pass + (test-assert #f) ; fail + (test-assert (vector-ref '#(3) 10)) ; fail with error + (test-end "a"))) + (eq? (test-runner-factory) test-runner-null)))) + +(test-end) + +;;; This got tested about as well as it could in 8.3.2 + +(test-begin "8.4. test-runner-create") +(test-end) + +;;; This got tested about as well as it could in 8.3.2 + +(test-begin "8.5. test-runner-factory") +(test-end) + +(test-begin "8.6. test-apply") +(test-equal "8.6.1. Simple (form 1) test-apply" + '(("w" "p" "v") () () () ("x") (3 0 0 0 1)) + (triv-runner + (lambda () + (test-begin "a") + (test-assert "w" #t) + (test-apply + (test-match-name "p") + (lambda () + (test-begin "p") + (test-assert "x" #t) + (test-end) + (test-begin "z") + (test-assert "p" #t) ; only this one should execute in here + (test-end))) + (test-assert "v" #t)))) + +(test-equal "8.6.2. Simple (form 2) test-apply" + '(("w" "p" "v") () () () ("x") (3 0 0 0 1)) + (triv-runner + (lambda () + (test-begin "a") + (test-assert "w" #t) + (test-apply + (test-runner-current) + (test-match-name "p") + (lambda () + (test-begin "p") + (test-assert "x" #t) + (test-end) + (test-begin "z") + (test-assert "p" #t) ; only this one should execute in here + (test-end))) + (test-assert "v" #t)))) + +(test-expect-fail 1) ;; depends on all test-match-nth being called. +(test-equal "8.6.3. test-apply with skips" + '(("w" "q" "v") () () () ("x" "p" "x") (3 0 0 0 3)) + (triv-runner + (lambda () + (test-begin "a") + (test-assert "w" #t) + (test-skip (test-match-nth 2)) + (test-skip (test-match-nth 4)) + (test-apply + (test-runner-current) + (test-match-name "p") + (test-match-name "q") + (lambda () + ; only execute if SKIP=no and APPLY=yes + (test-assert "x" #t) ; # 1 SKIP=no APPLY=no + (test-assert "p" #t) ; # 2 SKIP=yes APPLY=yes + (test-assert "q" #t) ; # 3 SKIP=no APPLY=yes + (test-assert "x" #f) ; # 4 SKIP=yes APPLY=no + 0)) + (test-assert "v" #t)))) + +;;; Unfortunately, since there is no way to UNBIND the current test runner, +;;; there is no way to test the behavior of `test-apply' in the absence +;;; of a current runner within our little meta-test framework. +;;; +;;; To test the behavior manually, you should be able to invoke: +;;; +;;; (test-apply "a" (lambda () (test-assert "a" #t))) +;;; +;;; from the top level (with SRFI 64 available) and it should create a +;;; new, default (simple) test runner. + +(test-end) + +;;; This entire suite depends heavily on 'test-with-runner'. If it didn't +;;; work, this suite would probably go down in flames +(test-begin "8.7. test-with-runner") +(test-end) + +;;; Again, this suite depends heavily on many of the test-runner +;;; components. We'll just test those that aren't being exercised +;;; by the meta-test framework +(test-begin "8.8. test-runner components") + +(define (auxtrack-runner thunk) + (let ((r (test-runner-null))) + (test-runner-aux-value! r '()) + (test-runner-on-test-end! r (lambda (r) + (test-runner-aux-value! + r + (cons (test-runner-test-name r) + (test-runner-aux-value r))))) + (test-with-runner r (thunk)) + (reverse (test-runner-aux-value r)))) + +(test-equal "8.8.1. test-runner-aux-value" + '("x" "" "y") + (auxtrack-runner + (lambda () + (test-assert "x" #t) + (test-begin "a") + (test-assert #t) + (test-end) + (test-assert "y" #f)))) + +(test-end) ; 8.8 + +(test-end "8. Test-runner") + +(test-begin "9. Test Result Properties") + +(test-begin "9.1. test-result-alist") + +(define (symbol-alist? l) + (if (null? l) + #t + (and (pair? l) + (pair? (car l)) + (symbol? (caar l)) + (symbol-alist? (cdr l))))) + +;;; check the various syntactic forms + +(test-assert (symbol-alist? + (car (on-test-runner + (lambda () + (test-assert #t)) + (lambda (r) + (test-result-alist r)))))) + +(test-assert (symbol-alist? + (car (on-test-runner + (lambda () + (test-assert #t)) + (lambda (r) + (test-result-alist r)))))) + +;;; check to make sure the required properties are returned + +(test-equal '((result-kind . pass)) + (prop-runner + '(result-kind) + (lambda () + (test-assert #t))) + ) + +(test-equal + '((result-kind . fail) + (expected-value . 2) + (actual-value . 3)) + (prop-runner + '(result-kind expected-value actual-value) + (lambda () + (test-equal 2 (+ 1 2))))) + +(test-end "9.1. test-result-alist") + +(test-begin "9.2. test-result-ref") + +(test-equal '(pass) + (on-test-runner + (lambda () + (test-assert #t)) + (lambda (r) + (test-result-ref r 'result-kind)))) + +(test-equal '(pass) + (on-test-runner + (lambda () + (test-assert #t)) + (lambda (r) + (test-result-ref r 'result-kind)))) + +(test-equal '(fail pass) + (on-test-runner + (lambda () + (test-assert (= 1 2)) + (test-assert (= 1 1))) + (lambda (r) + (test-result-ref r 'result-kind)))) + +(test-end "9.2. test-result-ref") + +(test-begin "9.3. test-result-set!") + +(test-equal '(100 100) + (on-test-runner + (lambda () + (test-assert (= 1 2)) + (test-assert (= 1 1))) + (lambda (r) + (test-result-set! r 'foo 100) + (test-result-ref r 'foo)))) + +(test-end "9.3. test-result-set!") + +(test-end "9. Test Result Properties") + +;;; +;;; +;;; + +#| Time to stop having fun... + +(test-begin "9. For fun, some meta-test errors") + +(test-equal + "9.1. Really PASSes, but test like it should FAIL" + '(() ("b") () () ()) + (triv-runner + (lambda () + (test-assert "b" #t)))) + +(test-expect-fail "9.2. Expect to FAIL and do so") +(test-expect-fail "9.3. Expect to FAIL but PASS") +(test-skip "9.4. SKIP this one") + +(test-assert "9.2. Expect to FAIL and do so" #f) +(test-assert "9.3. Expect to FAIL but PASS" #t) +(test-assert "9.4. SKIP this one" #t) + +(test-end) + |# + +(test-end "SRFI 64 - Meta-Test Suite") + +;;; diff --git a/test-suite/tests/srfi-64.test b/test-suite/tests/srfi-64.test new file mode 100644 index 000000000..190d6b23a --- /dev/null +++ b/test-suite/tests/srfi-64.test @@ -0,0 +1,45 @@ +;;;; srfi-64.test --- Test suite for SRFI-64. -*- 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 + +(define-module (test-srfi-64) + #:use-module ((test-suite lib) #:select (report)) + #:use-module (srfi srfi-64)) + +(define (guile-test-runner) + (let ((runner (test-runner-null))) + (test-runner-on-test-end! runner + (lambda (runner) + (let* ((result-alist (test-result-alist runner)) + (result-kind (assq-ref result-alist 'result-kind)) + (test-name (list (assq-ref result-alist 'test-name)))) + (case result-kind + ((pass) (report 'pass test-name)) + ((xpass) (report 'upass test-name)) + ((skip) (report 'untested test-name)) + ((fail xfail) + (apply report result-kind test-name result-alist)) + (else #t))))) + runner)) + +(test-with-runner + (guile-test-runner) + (primitive-load-path "tests/srfi-64-test.scm")) + +;;; Local Variables: +;;; eval: (put 'test-runner-on-test-end! 'scheme-indent-function 1) +;;; End: