[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.9-178-g34e89
|
From: |
Mark H Weaver |
|
Subject: |
[Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.9-178-g34e8987 |
|
Date: |
Sat, 01 Feb 2014 06:23:01 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=34e89877342f20fdb8a531ad78dab34cfd2b0843
The branch, stable-2.0 has been updated
via 34e89877342f20fdb8a531ad78dab34cfd2b0843 (commit)
via 9060dc29d51faac0d8f4f51047a3d20f27fbbf6d (commit)
via 58147d67806e1f54c447d7eabac35b1a5086c3a6 (commit)
from e6c1c5f6cb16913eadeb8758cd817c5a58d146b8 (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 34e89877342f20fdb8a531ad78dab34cfd2b0843
Author: Mark H Weaver <address@hidden>
Date: Wed Jan 29 02:20:01 2014 -0500
Implement SRFI-64 - A Scheme API for test suites.
* module/srfi/srfi-64.scm: New file.
* module/srfi/srfi-64/testing.scm: New file.
* module/Makefile.am: Add rule for srfi-64.go dependency on
srfi-64/testing.scm.
(SRFI_SOURCES): Add srfi/srfi-64.scm.
(NOCOMP_SOURCES): Add srfi/srfi-64/testing.scm.
* doc/ref/srfi-modules.texi (SRFI-64): New node.
* test-suite/tests/srfi-64.test: New file.
* test-suite/tests/srfi-64-test.scm: New file.
* test-suite/Makefile.am (SCM_TESTS): Add test-suite/tests/srfi-64.test.
(EXTRA_DIST): Add tests/srfi-64-test.scm.
commit 9060dc29d51faac0d8f4f51047a3d20f27fbbf6d
Author: Mark H Weaver <address@hidden>
Date: Mon Jan 27 17:17:23 2014 -0500
Implement SRFI-43 Vector Library.
* module/srfi/srfi-43.scm: New file.
* module/Makefile.am (SRFI_SOURCES): Add module/srfi/srfi-43.scm.
* test-suite/tests/srfi-43.test: New file.
* test-suite/Makefile.am (SCM_TESTS): Add test-suite/tests/srfi-43.test.
* doc/ref/srfi-modules.texi (SRFI-43, SRFI-43 Constructors)
(SRFI-43 Predicates, SRFI-43 Selectors, SRFI-43 Iteration)
(SRFI-43 Searching, SRFI-43 Mutators, SRFI-43 Conversion): New nodes.
commit 58147d67806e1f54c447d7eabac35b1a5086c3a6
Author: Mark H Weaver <address@hidden>
Date: Tue Jan 28 17:44:22 2014 -0500
Compile numerical comparisons with more than 2 arguments to VM code.
* module/language/tree-il/primitives.scm (chained-comparison-expander):
New procedure.
(*primitive-expand-table*): Add primitive expanders for '<', '>',
'<=', '>=', and '='.
-----------------------------------------------------------------------
Summary of changes:
doc/ref/srfi-modules.texi | 420 ++++++++++
module/Makefile.am | 8 +-
module/language/tree-il/primitives.scm | 23 +
module/srfi/srfi-43.scm | 1077 +++++++++++++++++++++++++
module/srfi/srfi-64.scm | 55 ++
module/srfi/srfi-64/testing.scm | 1040 ++++++++++++++++++++++++
test-suite/Makefile.am | 5 +-
test-suite/tests/srfi-43.test | 1375 ++++++++++++++++++++++++++++++++
test-suite/tests/srfi-64-test.scm | 934 ++++++++++++++++++++++
test-suite/tests/srfi-64.test | 45 +
10 files changed, 4980 insertions(+), 2 deletions(-)
create mode 100644 module/srfi/srfi-43.scm
create mode 100644 module/srfi/srfi-64.scm
create mode 100644 module/srfi/srfi-64/testing.scm
create mode 100644 test-suite/tests/srfi-43.test
create mode 100644 test-suite/tests/srfi-64-test.scm
create mode 100644 test-suite/tests/srfi-64.test
diff --git a/doc/ref/srfi-modules.texi b/doc/ref/srfi-modules.texi
index 8845c85..59059c7 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.
@@ -4511,6 +4513,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}.
address@hidden SRFI-43
address@hidden SRFI-43 - Vector Library
address@hidden SRFI-43
+
+This subsection is based on the
address@hidden://srfi.schemers.org/srfi-43/srfi-43.html, specification of
+SRFI-43} by Taylor Campbell.
+
address@hidden The copyright notice and license text of the SRFI-43
specification is
address@hidden reproduced below:
+
address@hidden Copyright (C) Taylor Campbell (2003). All Rights Reserved.
+
address@hidden Permission is hereby granted, free of charge, to any person
obtaining a
address@hidden copy of this software and associated documentation files (the
address@hidden "Software"), to deal in the Software without restriction,
including
address@hidden without limitation the rights to use, copy, modify, merge,
publish,
address@hidden distribute, sublicense, and/or sell copies of the Software, and
to
address@hidden permit persons to whom the Software is furnished to do so,
subject to
address@hidden the following conditions:
+
address@hidden The above copyright notice and this permission notice shall be
included
address@hidden in all copies or substantial portions of the Software.
+
address@hidden THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
EXPRESS
address@hidden OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
address@hidden MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
address@hidden NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
HOLDERS BE
address@hidden LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
ACTION
address@hidden OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
CONNECTION
address@hidden WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
address@hidden
+SRFI-43 implements a comprehensive library of vector operations. It can
+be made available with:
+
address@hidden
+(use-modules (srfi srfi-43))
address@hidden example
+
address@hidden
+* SRFI-43 Constructors::
+* SRFI-43 Predicates::
+* SRFI-43 Selectors::
+* SRFI-43 Iteration::
+* SRFI-43 Searching::
+* SRFI-43 Mutators::
+* SRFI-43 Conversion::
address@hidden menu
+
address@hidden SRFI-43 Constructors
address@hidden SRFI-43 Constructors
+
address@hidden {Scheme Procedure} make-vector size [fill]
+Create and return a vector of size @var{size}, optionally filling it
+with @var{fill}. The default value of @var{fill} is unspecified.
+
address@hidden
+(make-vector 5 3) @result{} #(3 3 3 3 3)
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} vector x @dots{}
+Create and return a vector whose elements are @var{x} @enddots{}.
+
address@hidden
+(vector 0 1 2 3 4) @result{} #(0 1 2 3 4)
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-unfold f length initial-seed @dots{}
+The fundamental vector constructor. Create a vector whose length is
address@hidden and iterates across each index k from 0 up to
address@hidden - 1, applying @var{f} at each iteration to the current index
+and current seeds, in that order, to receive n + 1 values: first, the
+element to put in the kth slot of the new vector and n new seeds for
+the next iteration. It is an error for the number of seeds to vary
+between iterations.
+
address@hidden
+(vector-unfold (lambda (i x) (values x (- x 1)))
+ 10 0)
address@hidden #(0 -1 -2 -3 -4 -5 -6 -7 -8 -9)
+
+(vector-unfold values 10)
address@hidden #(0 1 2 3 4 5 6 7 8 9)
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-unfold-right f length initial-seed
@dots{}
+Like @code{vector-unfold}, but it uses @var{f} to generate elements from
+right-to-left, rather than left-to-right.
+
address@hidden
+(vector-unfold-right (lambda (i x) (values x (+ x 1)))
+ 10 0)
address@hidden #(9 8 7 6 5 4 3 2 1 0)
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-copy vec [start [end [fill]]]
+Allocate a new vector whose length is @var{end} - @var{start} and fills
+it with elements from @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
address@hidden(vector-length vec)}. If @var{end} extends beyond the length of
address@hidden, the slots in the new vector that obviously cannot be filled
+by elements from @var{vec} are filled with @var{fill}, whose default
+value is unspecified.
+
address@hidden
+(vector-copy '#(a b c d e f g h i))
address@hidden #(a b c d e f g h i)
+
+(vector-copy '#(a b c d e f g h i) 6)
address@hidden #(g h i)
+
+(vector-copy '#(a b c d e f g h i) 3 6)
address@hidden #(d e f)
+
+(vector-copy '#(a b c d e f g h i) 6 12 'x)
address@hidden #(g h i x x x)
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-reverse-copy vec [start [end]]
+Like @code{vector-copy}, but it copies the elements in the reverse order
+from @var{vec}.
+
address@hidden
+(vector-reverse-copy '#(5 4 3 2 1 0) 1 5)
address@hidden #(1 2 3 4)
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-append vec @dots{}
+Return a newly allocated vector that contains all elements in order from
+the subsequent locations in @var{vec} @enddots{}.
+
address@hidden
+(vector-append '#(a) '#(b c d))
address@hidden #(a b c d)
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-concatenate list-of-vectors
+Append each vector in @var{list-of-vectors}. Equivalent to
address@hidden(apply vector-append list-of-vectors)}.
+
address@hidden
+(vector-concatenate '(#(a b) #(c d)))
address@hidden #(a b c d)
address@hidden example
address@hidden deffn
+
address@hidden SRFI-43 Predicates
address@hidden SRFI-43 Predicates
+
address@hidden {Scheme Procedure} vector? obj
+Return true if @var{obj} is a vector, else return false.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-empty? vec
+Return true if @var{vec} is empty, i.e. its length is 0, else return
+false.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector= elt=? vec @dots{}
+Return true if the vectors @var{vec} @dots{} have equal lengths and
+equal elements according to @var{elt=?}. @var{elt=?} is always applied
+to two arguments. Element comparison must be consistent with @code{eq?}
+in the following sense: if @code{(eq? a b)} returns true, then
address@hidden(elt=? a b)} must also return true. The order in which
+comparisons are performed is unspecified.
address@hidden deffn
+
address@hidden SRFI-43 Selectors
address@hidden SRFI-43 Selectors
+
address@hidden {Scheme Procedure} vector-ref vec i
+Return the value that the location in @var{vec} at @var{i} is mapped to
+in the store. Indexing is based on zero.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-length vec
+Return the length of @var{vec}.
address@hidden deffn
+
address@hidden SRFI-43 Iteration
address@hidden SRFI-43 Iteration
+
address@hidden {Scheme Procedure} vector-fold kons knil vec1 vec2 @dots{}
+The fundamental vector iterator. @var{kons} is iterated over each index
+in all of the vectors, stopping at the end of the shortest; @var{kons}
+is applied as
address@hidden
+(kons i state (vector-ref vec1 i) (vector-ref vec2 i) ...)
address@hidden smalllisp
+where @var{state} is the current state value, and @var{i} is the current
+index. The current state value begins with @var{knil}, and becomes
+whatever @var{kons} returned at the respective iteration. The iteration
+is strictly left-to-right.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-fold-right kons knil vec1 vec2 @dots{}
+Similar to @code{vector-fold}, but it iterates right-to-left instead of
+left-to-right.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-map f vec1 vec2 @dots{}
+Return a new vector of the shortest size of the vector arguments. Each
+element at index i of the new vector is mapped from the old vectors by
address@hidden
+(f i (vector-ref vec1 i) (vector-ref vec2 i) ...)
address@hidden smalllisp
+The dynamic order of application of @var{f} is unspecified.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-map! f vec1 vec2 @dots{}
+Similar to @code{vector-map}, but rather than mapping the new elements
+into a new vector, the new mapped elements are destructively inserted
+into @var{vec1}. The dynamic order of application of @var{f} is
+unspecified.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-for-each f vec1 vec2 @dots{}
+Call @code{(f i (vector-ref vec1 i) (vector-ref vec2 i) ...)} for each
+index i less than the length of the shortest vector passed. The
+iteration is strictly left-to-right.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-count pred? vec1 vec2 @dots{}
+Count the number of parallel elements in the vectors that satisfy
address@hidden, which is applied, for each index i less than the length of
+the smallest vector, to i and each parallel element in the vectors at
+that index, in order.
+
address@hidden
+(vector-count (lambda (i elt) (even? elt))
+ '#(3 1 4 1 5 9 2 5 6))
address@hidden 3
+(vector-count (lambda (i x y) (< x y))
+ '#(1 3 6 9) '#(2 4 6 8 10 12))
address@hidden 2
address@hidden example
address@hidden deffn
+
address@hidden SRFI-43 Searching
address@hidden SRFI-43 Searching
+
address@hidden {Scheme Procedure} vector-index pred? vec1 vec2 @dots{}
+Find and return the index of the first elements in @var{vec1} @var{vec2}
address@hidden that satisfy @var{pred?}. If no matching element is found by
+the end of the shortest vector, return @code{#f}.
+
address@hidden
+(vector-index even? '#(3 1 4 1 5 9))
address@hidden 2
+(vector-index < '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2))
address@hidden 1
+(vector-index = '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2))
address@hidden #f
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-index-right pred? vec1 vec2 @dots{}
+Like @code{vector-index}, but it searches right-to-left, rather than
+left-to-right. Note that the SRFI 43 specification requires that all
+the vectors must have the same length, but both the SRFI 43 reference
+implementation and Guile's implementation allow vectors with unequal
+lengths, and start searching from the last index of the shortest vector.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-skip pred? vec1 vec2 @dots{}
+Find and return the index of the first elements in @var{vec1} @var{vec2}
address@hidden that do not satisfy @var{pred?}. If no matching element is
+found by the end of the shortest vector, return @code{#f}. Equivalent
+to @code{vector-index} but with the predicate inverted.
+
address@hidden
+(vector-skip number? '#(1 2 a b 3 4 c d)) @result{} 2
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-skip-right pred? vec1 vec2 @dots{}
+Like @code{vector-skip}, but it searches for a non-matching element
+right-to-left, rather than left-to-right. Note that the SRFI 43
+specification requires that all the vectors must have the same length,
+but both the SRFI 43 reference implementation and Guile's implementation
+allow vectors with unequal lengths, and start searching from the last
+index of the shortest vector.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-binary-search vec value cmp [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}.
+
address@hidden 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
address@hidden > 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.
+
address@hidden
+(define (char-cmp c1 c2)
+ (cond ((char<? c1 c2) -1)
+ ((char>? c1 c2) 1)
+ (else 0)))
+
+(vector-binary-search '#(#\a #\b #\c #\d #\e #\f #\g #\h)
+ #\g
+ char-cmp)
address@hidden 6
address@hidden example
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-any pred? vec1 vec2 @dots{}
+Find the first parallel set of elements from @var{vec1} @var{vec2}
address@hidden for which @var{pred?} returns a true value. If such a parallel
+set of elements exists, @code{vector-any} returns the value that
address@hidden returned for that set of elements. The iteration is
+strictly left-to-right.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-every pred? vec1 vec2 @dots{}
+If, for every index i between 0 and the length of the shortest vector
+argument, the set of elements @code{(vector-ref vec1 i)}
address@hidden(vector-ref vec2 i)} @dots{} satisfies @var{pred?},
address@hidden returns the value that @var{pred?} returned for the
+last set of elements, at the last index of the shortest vector.
+Otherwise it returns @code{#f}. The iteration is strictly
+left-to-right.
address@hidden deffn
+
address@hidden SRFI-43 Mutators
address@hidden SRFI-43 Mutators
+
address@hidden {Scheme Procedure} vector-set! vec i value
+Assign the contents of the location at @var{i} in @var{vec} to
address@hidden
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-swap! vec i j
+Swap the values of the locations in @var{vec} at @var{i} and @var{j}.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-fill! vec fill [start [end]]
+Assign the value of every location in @var{vec} between @var{start} and
address@hidden to @var{fill}. @var{start} defaults to 0 and @var{end}
+defaults to the length of @var{vec}.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-reverse! vec [start [end]]
+Destructively reverse the contents of @var{vec} between @var{start} and
address@hidden @var{start} defaults to 0 and @var{end} defaults to the
+length of @var{vec}.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-copy! target tstart source [sstart
[send]]
+Copy a block of elements from @var{source} to @var{target}, both of
+which must be vectors, starting in @var{target} at @var{tstart} and
+starting in @var{source} at @var{sstart}, ending when (@var{send} -
address@hidden) elements have been copied. It is an error for
address@hidden to have a length less than (@var{tstart} + @var{send} -
address@hidden). @var{sstart} defaults to 0 and @var{send} defaults to
+the length of @var{source}.
address@hidden deffn
+
address@hidden {Scheme Procedure} vector-reverse-copy! target tstart source
[sstart [send]]
+Like @code{vector-copy!}, but this copies the elements in the reverse
+order. It is an error if @var{target} and @var{source} are identical
+vectors and the @var{target} and @var{source} ranges overlap; however,
+if @var{tstart} = @var{sstart}, @code{vector-reverse-copy!} behaves as
address@hidden(vector-reverse! target tstart send)} would.
address@hidden deffn
+
address@hidden SRFI-43 Conversion
address@hidden SRFI-43 Conversion
+
address@hidden {Scheme Procedure} vector->list vec [start [end]]
+Return a newly allocated list containing the elements in @var{vec}
+between @var{start} and @var{end}. @var{start} defaults to 0 and
address@hidden defaults to the length of @var{vec}.
address@hidden deffn
+
address@hidden {Scheme Procedure} reverse-vector->list vec [start [end]]
+Like @code{vector->list}, but the resulting list contains the specified
+range of elements of @var{vec} in reverse order.
address@hidden deffn
+
address@hidden {Scheme Procedure} list->vector proper-list [start [end]]
+Return a newly allocated vector of the elements from @var{proper-list}
+with indices between @var{start} and @var{end}. @var{start} defaults to
+0 and @var{end} defaults to the length of @var{proper-list}. Note that
+SRFI 43 does not document the @var{start} and @var{end} arguments, but
+both its reference implementation and Guile's implementation support
+them.
address@hidden deffn
+
address@hidden {Scheme Procedure} reverse-list->vector proper-list [start [end]]
+Like @code{list->vector}, but the resulting 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.
address@hidden deffn
+
@node SRFI-45
@subsection SRFI-45 - Primitives for Expressing Iterative Lazy Algorithms
@cindex SRFI-45
@@ -4859,6 +5272,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.
address@hidden SRFI-64
address@hidden SRFI-64 - A Scheme API for test suites.
address@hidden 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 47b9c2c..cbdbbc9 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 Free Software Foundation,
Inc.
+## Copyright (C) 2009, 2010, 2011, 2012, 2013,
+## 2014 Free Software Foundation, Inc.
##
## This file is part of GUILE.
##
@@ -264,6 +265,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 \
@@ -289,9 +292,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 \
@@ -399,6 +404,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/language/tree-il/primitives.scm
b/module/language/tree-il/primitives.scm
index f140eec..9901876 100644
--- a/module/language/tree-il/primitives.scm
+++ b/module/language/tree-il/primitives.scm
@@ -491,6 +491,29 @@
(define-primitive-expander f64vector-set! (vec i x)
(bytevector-ieee-double-native-set! vec (* i 8) x))
+(define (chained-comparison-expander prim-name)
+ (case-lambda
+ ((src) (make-const src #t))
+ ((src a) #f)
+ ((src a b) #f)
+ ((src a b . rest)
+ (let* ((prim (make-primitive-ref src prim-name))
+ (b-sym (gensym "b"))
+ (b* (make-lexical-ref src 'b b-sym)))
+ (make-let src
+ '(b)
+ (list b-sym)
+ (list b)
+ (make-conditional src
+ (make-application src prim (list a b*))
+ (make-application src prim (cons b* rest))
+ (make-const src #f)))))))
+
+(for-each (lambda (prim-name)
+ (hashq-set! *primitive-expand-table* prim-name
+ (chained-comparison-expander prim-name)))
+ '(< > <= >= =))
+
;; Appropriate for use with either 'eqv?' or 'equal?'.
(define maybe-simplify-to-eq
(case-lambda
diff --git a/module/srfi/srfi-43.scm b/module/srfi/srfi-43.scm
new file mode 100644
index 0000000..88a3f3f
--- /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 <address@hidden>
+
+(define-module (srfi srfi-43)
+ #:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-8)
+ #:re-export (make-vector vector vector? vector-ref vector-set!
+ vector-length)
+ #:replace (vector-copy vector-fill! list->vector vector->list)
+ #:export (vector-empty? vector= vector-unfold vector-unfold-right
+ vector-reverse-copy
+ vector-append vector-concatenate
+ vector-fold vector-fold-right
+ vector-map vector-map!
+ vector-for-each vector-count
+ vector-index vector-index-right
+ vector-skip vector-skip-right
+ vector-binary-search
+ vector-any vector-every
+ vector-swap! vector-reverse!
+ vector-copy! vector-reverse-copy!
+ reverse-vector->list
+ reverse-list->vector))
+
+(cond-expand-provide (current-module) '(srfi-43))
+
+(define (error-from who msg . args)
+ (apply error
+ (string-append (symbol->string who) ": " msg)
+ args))
+
+(define-syntax-rule (assert-nonneg-exact-integer k who)
+ (unless (and (exact-integer? k)
+ (not (negative? k)))
+ (error-from who "expected non-negative exact integer, got" k)))
+
+(define-syntax-rule (assert-procedure f who)
+ (unless (procedure? f)
+ (error-from who "expected procedure, got" f)))
+
+(define-syntax-rule (assert-vector v who)
+ (unless (vector? v)
+ (error-from who "expected vector, got" v)))
+
+(define-syntax-rule (assert-valid-index i len who)
+ (unless (and (exact-integer? i)
+ (<= 0 i 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 0000000..81dcc5d
--- /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 0000000..d686662
--- /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 <address@hidden>, 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 <java.lang.Throwable>
+ (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 <java.lang.Throwable>
+ (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 <java.lang.Throwable>
+ (test-result-set! r 'actual-error ex)
+ (cond ((and (instance? et
<gnu.bytecode.ClassType>)
+
(gnu.bytecode.ClassType:isSubclass et <java.lang.Throwable>))
+ (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 00f62fe..7578bf5 100644
--- a/test-suite/Makefile.am
+++ b/test-suite/Makefile.am
@@ -133,8 +133,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 \
@@ -173,7 +175,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 0000000..554843e
--- /dev/null
+++ b/test-suite/tests/srfi-43.test
@@ -0,0 +1,1375 @@
+;;;; srfi-43.test --- test suite for SRFI-43 Vector library -*- scheme -*-
+;;;;
+;;;; Copyright (C) 2014 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
+
+;;;
+;;; Originally written by Shiro Kawai and placed in the public domain
+;;; 10/5/2005.
+;;;
+;;; Many tests added, and adapted for Guile's (test-suite lib)
+;;; by Mark H Weaver <address@hidden>, Jan 2014.
+;;;
+
+(define-module (test-suite test-srfi-43)
+ #:use-module (srfi srfi-43)
+ #:use-module (test-suite lib))
+
+(define-syntax-rule (pass-if-error name body0 body ...)
+ (pass-if name
+ (catch #t
+ (lambda () body0 body ... #f)
+ (lambda (key . args) #t))))
+
+;;;
+;;; Constructors
+;;;
+
+;;
+;; make-vector
+;;
+
+(with-test-prefix "make-vector"
+
+ (pass-if-equal "simple, no init"
+ 5
+ (vector-length (make-vector 5)))
+
+ (pass-if-equal "empty"
+ '#()
+ (make-vector 0))
+
+ (pass-if-error "negative length"
+ (make-vector -4))
+
+ (pass-if-equal "simple with init"
+ '#(3 3 3 3 3)
+ (make-vector 5 3))
+
+ (pass-if-equal "empty with init"
+ '#()
+ (make-vector 0 3))
+
+ (pass-if-error "negative length"
+ (make-vector -1 3)))
+
+;;
+;; vector
+;;
+
+(with-test-prefix "vector"
+
+ (pass-if-equal "no args"
+ '#()
+ (vector))
+
+ (pass-if-equal "simple"
+ '#(1 2 3 4 5)
+ (vector 1 2 3 4 5)))
+
+;;
+;; vector-unfold
+;;
+
+(with-test-prefix "vector-unfold"
+
+ (pass-if-equal "no seeds"
+ '#(0 1 2 3 4 5 6 7 8 9)
+ (vector-unfold values 10))
+
+ (pass-if-equal "no seeds, zero len"
+ '#()
+ (vector-unfold values 0))
+
+ (pass-if-error "no seeds, negative len"
+ (vector-unfold values -1))
+
+ (pass-if-equal "1 seed"
+ '#(0 -1 -2 -3 -4 -5 -6 -7 -8 -9)
+ (vector-unfold (lambda (i x) (values x (- x 1)))
+ 10 0))
+
+ (pass-if-equal "1 seed, zero len"
+ '#()
+ (vector-unfold values 0 1))
+
+ (pass-if-error "1 seed, negative len"
+ (vector-unfold values -2 1))
+
+ (pass-if-equal "2 seeds"
+ '#((0 20) (-1 21) (-2 22) (-3 23) (-4 24)
+ (-5 25) (-6 26) (-7 27) (-8 28) (-9 29))
+ (vector-unfold (lambda (i x y) (values (list x y) (- x 1) (+ y 1)))
+ 10 0 20))
+
+ (pass-if-equal "2 seeds, zero len"
+ '#()
+ (vector-unfold values 0 1 2))
+
+ (pass-if-error "2 seeds, negative len"
+ (vector-unfold values -2 1 2))
+
+ (pass-if-equal "3 seeds"
+ '#((0 20 30) (-1 21 32) (-2 22 34) (-3 23 36) (-4 24 38)
+ (-5 25 40) (-6 26 42) (-7 27 44) (-8 28 46) (-9 29 48))
+ (vector-unfold (lambda (i x y z)
+ (values (list x y z) (- x 1) (+ y 1) (+ z 2)))
+ 10 0 20 30))
+
+ (pass-if-equal "3 seeds, zero len"
+ '#()
+ (vector-unfold values 0 1 2 3))
+
+ (pass-if-error "3 seeds, negative len"
+ (vector-unfold values -2 1 2 3)))
+
+;;
+;; vector-unfold-right
+;;
+
+(with-test-prefix "vector-unfold-right"
+
+ (pass-if-equal "no seeds, zero len"
+ '#()
+ (vector-unfold-right values 0))
+
+ (pass-if-error "no seeds, negative len"
+ (vector-unfold-right values -1))
+
+ (pass-if-equal "1 seed"
+ '#(9 8 7 6 5 4 3 2 1 0)
+ (vector-unfold-right (lambda (i x) (values x (+ x 1))) 10 0))
+
+ (pass-if-equal "1 seed, zero len"
+ '#()
+ (vector-unfold-right values 0 1))
+
+ (pass-if-error "1 seed, negative len"
+ (vector-unfold-right values -1 1))
+
+ (pass-if-equal "1 seed, reverse vector"
+ '#(e d c b a)
+ (let ((vector '#(a b c d e)))
+ (vector-unfold-right
+ (lambda (i x) (values (vector-ref vector x) (+ x 1)))
+ (vector-length vector)
+ 0)))
+
+ (pass-if-equal "2 seeds"
+ '#((0 20) (-1 21) (-2 22) (-3 23) (-4 24)
+ (-5 25) (-6 26) (-7 27) (-8 28) (-9 29))
+ (vector-unfold-right (lambda (i x y) (values (list x y) (+ x 1) (- y 1)))
+ 10 -9 29))
+
+ (pass-if-equal "2 seeds, zero len"
+ '#()
+ (vector-unfold-right values 0 1 2))
+
+ (pass-if-error "2 seeds, negative len"
+ (vector-unfold-right values -1 1 2))
+
+ (pass-if-equal "3 seeds"
+ '#((0 20 30) (-1 21 32) (-2 22 34) (-3 23 36) (-4 24 38)
+ (-5 25 40) (-6 26 42) (-7 27 44) (-8 28 46) (-9 29 48))
+ (vector-unfold-right (lambda (i x y z)
+ (values (list x y z) (+ x 1) (- y 1) (- z 2)))
+ 10 -9 29 48))
+
+ (pass-if-equal "3 seeds, zero len"
+ '#()
+ (vector-unfold-right values 0 1 2 3))
+
+ (pass-if-error "3 seeds, negative len"
+ (vector-unfold-right values -1 1 2 3)))
+
+;;
+;; vector-copy
+;;
+
+(with-test-prefix "vector-copy"
+
+ (pass-if-equal "1 arg"
+ '#(a b c d e f g h i)
+ (vector-copy '#(a b c d e f g h i)))
+
+ (pass-if-equal "2 args"
+ '#(g h i)
+ (vector-copy '#(a b c d e f g h i) 6))
+
+ (pass-if-equal "3 args"
+ '#(d e f)
+ (vector-copy '#(a b c d e f g h i) 3 6))
+
+ (pass-if-equal "4 args"
+ '#(g h i x x x)
+ (vector-copy '#(a b c d e f g h i) 6 12 'x))
+
+ (pass-if-equal "3 args, empty range"
+ '#()
+ (vector-copy '#(a b c d e f g h i) 6 6))
+
+ (pass-if-error "3 args, invalid range"
+ (vector-copy '#(a b c d e f g h i) 4 2)))
+
+;;
+;; vector-reverse-copy
+;;
+
+(with-test-prefix "vector-reverse-copy"
+
+ (pass-if-equal "1 arg"
+ '#(e d c b a)
+ (vector-reverse-copy '#(a b c d e)))
+
+ (pass-if-equal "2 args"
+ '#(e d c)
+ (vector-reverse-copy '#(a b c d e) 2))
+
+ (pass-if-equal "3 args"
+ '#(d c b)
+ (vector-reverse-copy '#(a b c d e) 1 4))
+
+ (pass-if-equal "3 args, empty result"
+ '#()
+ (vector-reverse-copy '#(a b c d e) 1 1))
+
+ (pass-if-error "2 args, invalid range"
+ (vector-reverse-copy '#(a b c d e) 2 1)))
+
+;;
+;; vector-append
+;;
+
+(with-test-prefix "vector-append"
+
+ (pass-if-equal "no args"
+ '#()
+ (vector-append))
+
+ (pass-if-equal "1 arg"
+ '(#(1 2) #f)
+ (let* ((v (vector 1 2))
+ (v-copy (vector-append v)))
+ (list v-copy (eq? v v-copy))))
+
+ (pass-if-equal "2 args"
+ '#(x y)
+ (vector-append '#(x) '#(y)))
+
+ (pass-if-equal "3 args"
+ '#(x y x y x y)
+ (let ((v '#(x y)))
+ (vector-append v v v)))
+
+ (pass-if-equal "3 args with empty vector"
+ '#(x y)
+ (vector-append '#(x) '#() '#(y)))
+
+ (pass-if-error "3 args with non-vectors"
+ (vector-append '#() 'b 'c)))
+
+;;
+;; vector-concatenate
+;;
+
+(with-test-prefix "vector-concatenate"
+
+ (pass-if-equal "2 vectors"
+ '#(a b c d)
+ (vector-concatenate '(#(a b) #(c d))))
+
+ (pass-if-equal "no vectors"
+ '#()
+ (vector-concatenate '()))
+
+ (pass-if-error "non-vector in list"
+ (vector-concatenate '(#(a b) c))))
+
+;;;
+;;; Predicates
+;;;
+
+;;
+;; vector?
+;;
+
+(with-test-prefix "vector?"
+ (pass-if "empty vector" (vector? '#()))
+ (pass-if "simple" (vector? '#(a b)))
+ (pass-if "list" (not (vector? '(a b))))
+ (pass-if "symbol" (not (vector? 'a))))
+
+;;
+;; vector-empty?
+;;
+
+(with-test-prefix "vector-empty?"
+ (pass-if "empty vector" (vector-empty? '#()))
+ (pass-if "singleton vector" (not (vector-empty? '#(a))))
+ (pass-if-error "non-vector" (vector-empty 'a)))
+
+;;
+;; vector=
+;;
+
+(with-test-prefix "vector="
+
+ (pass-if "2 equal vectors"
+ (vector= eq? '#(a b c d) '#(a b c d)))
+
+ (pass-if "3 equal vectors"
+ (vector= eq? '#(a b c d) '#(a b c d) '#(a b c d)))
+
+ (pass-if "2 empty vectors"
+ (vector= eq? '#() '#()))
+
+ (pass-if "no vectors"
+ (vector= eq?))
+
+ (pass-if "1 vector"
+ (vector= eq? '#(a)))
+
+ (pass-if "2 unequal vectors of equal length"
+ (not (vector= eq? '#(a b c d) '#(a b d c))))
+
+ (pass-if "3 unequal vectors of equal length"
+ (not (vector= eq? '#(a b c d) '#(a b c d) '#(a b d c))))
+
+ (pass-if "2 vectors of unequal length"
+ (not (vector= eq? '#(a b c) '#(a b c d))))
+
+ (pass-if "3 vectors of unequal length"
+ (not (vector= eq? '#(a b c d) '#(a b c d) '#(a b c))))
+
+ (pass-if "2 vectors: empty, non-empty"
+ (not (vector= eq? '#() '#(a b d c))))
+
+ (pass-if "2 vectors: non-empty, empty"
+ (not (vector= eq? '#(a b d c) '#())))
+
+ (pass-if "2 equal vectors, elt= is equal?"
+ (vector= equal? '#("a" "b" "c") '#("a" "b" "c")))
+
+ (pass-if "2 equal vectors, elt= is ="
+ (vector= = '#(1/2 1/3 1/4 1/5) '#(1/2 1/3 1/4 1/5)))
+
+ (pass-if-error "vector and list"
+ (vector= equal? '#("a" "b" "c") '("a" "b" "c")))
+
+ (pass-if-error "non-procedure"
+ (vector= 1 '#("a" "b" "c") '("a" "b" "c"))))
+
+;;;
+;;; Selectors
+;;;
+
+;;
+;; vector-ref
+;;
+
+(with-test-prefix "vector-ref"
+ (pass-if-equal "simple 0" 'a (vector-ref '#(a b c) 0))
+ (pass-if-equal "simple 1" 'b (vector-ref '#(a b c) 1))
+ (pass-if-equal "simple 2" 'c (vector-ref '#(a b c) 2))
+ (pass-if-error "negative index" (vector-ref '#(a b c) -1))
+ (pass-if-error "index beyond end" (vector-ref '#(a b c) 3))
+ (pass-if-error "empty vector" (vector-ref '#() 0))
+ (pass-if-error "non-vector" (vector-ref '(a b c) 0))
+ (pass-if-error "inexact index" (vector-ref '#(a b c) 1.0)))
+
+;;
+;; vector-length
+;;
+
+(with-test-prefix "vector-length"
+ (pass-if-equal "empty vector" 0 (vector-length '#()))
+ (pass-if-equal "simple" 3 (vector-length '#(a b c)))
+ (pass-if-error "non-vector" (vector-length '(a b c))))
+
+;;;
+;;; Iteration
+;;;
+
+;;
+;; vector-fold
+;;
+
+(with-test-prefix "vector-fold"
+
+ (pass-if-equal "1 vector"
+ 10
+ (vector-fold (lambda (i seed val) (+ seed val))
+ 0
+ '#(0 1 2 3 4)))
+
+ (pass-if-equal "1 empty vector"
+ 'a
+ (vector-fold (lambda (i seed val) (+ seed val))
+ 'a
+ '#()))
+
+ (pass-if-equal "1 vector, use index"
+ 30
+ (vector-fold (lambda (i seed val) (+ seed (* i val)))
+ 0
+ '#(0 1 2 3 4)))
+
+ (pass-if-equal "2 vectors, unequal lengths"
+ '(1 -7 1 -1)
+ (vector-fold (lambda (i seed x y) (cons (- x y) seed))
+ '()
+ '#(6 1 2 3 4) '#(7 0 9 2)))
+
+ (pass-if-equal "3 vectors, unequal lengths"
+ '(51 33 31 19)
+ (vector-fold (lambda (i seed x y z) (cons (- x y z) seed))
+ '()
+ '#(6 1 2 3 4) '#(7 0 9 2) '#(-20 -30 -40 -50 -60 -70)))
+
+ (pass-if-error "5 args, non-vector"
+ (vector-fold (lambda (i seed x y z) (cons (- x y z) seed))
+ '()
+ '#(6 1 2 3 4) '#(7 0 9 2) '(-20 -30 -40 -50 -60 -70)))
+
+ (pass-if-error "non-procedure"
+ (vector-fold 1 '() '#(6 1 2 3 4) '#(7 0 9 2))))
+
+;;
+;; vector-fold-right
+;;
+
+(with-test-prefix "vector-fold-right"
+
+ (pass-if-equal "1 vector"
+ '((0 . a) (1 . b) (2 . c) (3 . d) (4 . e))
+ (vector-fold-right (lambda (i seed val) (cons (cons i val) seed))
+ '()
+ '#(a b c d e)))
+
+ (pass-if-equal "2 vectors, unequal lengths"
+ '(-1 1 -7 1)
+ (vector-fold-right (lambda (i seed x y) (cons (- x y) seed))
+ '()
+ '#(6 1 2 3 7) '#(7 0 9 2)))
+
+ (pass-if-equal "3 vectors, unequal lengths"
+ '(19 31 33 51)
+ (vector-fold-right (lambda (i seed x y z) (cons (- x y z) seed))
+ '()
+ '#(6 1 2 3 4) '#(7 0 9 2) '#(-20 -30 -40 -50 -60 -70)))
+
+ (pass-if-error "5 args, non-vector"
+ (vector-fold-right (lambda (i seed x y z) (cons (- x y z) seed))
+ '()
+ '#(6 1 2 3 4) '#(7 0 9 2) '(-20 -30 -40 -50 -60 -70)))
+
+ (pass-if-error "non-procedure"
+ (vector-fold-right 1 '() '#(6 1 2 3 4) '#(7 0 9 2))))
+
+;;
+;; vector-map
+;;
+
+(with-test-prefix "vector-map"
+
+ (pass-if-equal "1 vector"
+ '#((0 . a) (1 . b) (2 . c) (3 . d) (4 . e))
+ (vector-map cons '#(a b c d e)))
+
+ (pass-if-equal "1 empty vector"
+ '#()
+ (vector-map cons '#()))
+
+ (pass-if-equal "2 vectors, unequal lengths"
+ '#(5 8 11 14)
+ (vector-map + '#(0 1 2 3 4) '#(5 6 7 8)))
+
+ (pass-if-equal "3 vectors, unequal lengths"
+ '#(15 28 41 54)
+ (vector-map + '#(0 1 2 3 4) '#(5 6 7 8) '#(10 20 30 40 50 60)))
+
+ (pass-if-error "4 args, non-vector"
+ (vector-map + '#(0 1 2 3 4) '(5 6 7 8) '#(10 20 30 40 50 60)))
+
+ (pass-if-error "3 args, non-vector"
+ (vector-map + '#(0 1 2 3 4) '(5 6 7 8)))
+
+ (pass-if-error "non-procedure"
+ (vector-map #f '#(0 1 2 3 4) '#(5 6 7 8) '#(10 20 30 40 50 60))))
+
+;;
+;; vector-map!
+;;
+
+(with-test-prefix "vector-map!"
+
+ (pass-if-equal "1 vector"
+ '#(0 1 4 9 16)
+ (let ((v (vector 0 1 2 3 4)))
+ (vector-map! * v)
+ v))
+
+ (pass-if-equal "1 empty vector"
+ '#()
+ (let ((v (vector)))
+ (vector-map! * v)
+ v))
+
+ (pass-if-equal "2 vectors, unequal lengths"
+ '#(5 8 11 14 4)
+ (let ((v (vector 0 1 2 3 4)))
+ (vector-map! + v '#(5 6 7 8))
+ v))
+
+ (pass-if-equal "3 vectors, unequal lengths"
+ '#(15 28 41 54 4)
+ (let ((v (vector 0 1 2 3 4)))
+ (vector-map! + v '#(5 6 7 8) '#(10 20 30 40 50 60))
+ v))
+
+ (pass-if-error "non-vector"
+ (let ((v (vector 0 1 2 3 4)))
+ (vector-map! + v '#(5 6 7 8) '(10 20 30 40 50 60))
+ v))
+
+ (pass-if-error "non-procedure"
+ (let ((v (vector 0 1 2 3 4)))
+ (vector-map! '(1 . 2) v '#(5 6 7 8) '#(10 20 30 40 50 60))
+ v)))
+
+;;
+;; vector-for-each
+;;
+
+(with-test-prefix "vector-for-each"
+
+ (pass-if-equal "1 vector"
+ '(4 6 6 4 0)
+ (let ((lst '()))
+ (vector-for-each (lambda (i x)
+ (set! lst (cons (* i x) lst)))
+ '#(5 4 3 2 1))
+ lst))
+
+ (pass-if-equal "1 empty vector"
+ '()
+ (let ((lst '()))
+ (vector-for-each (lambda (i x)
+ (set! lst (cons (* i x) lst)))
+ '#())
+ lst))
+
+ (pass-if-equal "2 vectors, unequal lengths"
+ '(13 11 7 2)
+ (let ((lst '()))
+ (vector-for-each (lambda (i x y)
+ (set! lst (cons (+ (* i x) y) lst)))
+ '#(5 4 3 2 1)
+ '#(2 3 5 7))
+ lst))
+
+ (pass-if-equal "3 vectors, unequal lengths"
+ '(-6 -6 -6 -9)
+ (let ((lst '()))
+ (vector-for-each (lambda (i x y z)
+ (set! lst (cons (+ (* i x) (- y z)) lst)))
+ '#(5 4 3 2 1)
+ '#(2 3 5 7)
+ '#(11 13 17 19 23 29))
+ lst))
+
+ (pass-if-error "non-vector"
+ (let ((lst '()))
+ (vector-for-each (lambda (i x y z)
+ (set! lst (cons (+ (* i x) (- y z)) lst)))
+ '#(5 4 3 2 1)
+ '(2 3 5 7)
+ '#(11 13 17 19 23 29))
+ lst))
+
+ (pass-if-error "non-procedure"
+ (let ((lst '()))
+ (vector-for-each '#(not a procedure)
+ '#(5 4 3 2 1)
+ '#(2 3 5 7)
+ '#(11 13 17 19 23 29))
+ lst)))
+
+;;
+;; vector-count
+;;
+
+(with-test-prefix "vector-count"
+
+ (pass-if-equal "1 vector"
+ 3
+ (vector-count (lambda (i x) (even? (+ i x))) '#(2 3 5 7 11)))
+
+ (pass-if-equal "1 empty vector"
+ 0
+ (vector-count values '#()))
+
+ (pass-if-equal "2 vectors, unequal lengths"
+ 3
+ (vector-count (lambda (i x y) (< x (* i y)))
+ '#(8 2 7 8 9 1 0)
+ '#(7 6 4 3 1)))
+
+ (pass-if-equal "3 vectors, unequal lengths"
+ 2
+ (vector-count (lambda (i x y z) (<= x (- y i) z))
+ '#(3 6 3 0 2 4 1)
+ '#(8 7 4 4 9)
+ '#(7 6 8 3 1 7 9)))
+
+ (pass-if-error "non-vector"
+ (vector-count (lambda (i x y z) (<= x (- y i) z))
+ '#(3 6 3 0 2 4 1)
+ '#(8 7 4 4 9)
+ '(7 6 8 3 1 7 9)))
+
+ (pass-if-error "non-procedure"
+ (vector-count '(1 2)
+ '#(3 6 3 0 2 4 1)
+ '#(8 7 4 4 9)
+ '#(7 6 8 3 1 7 9))))
+
+;;;
+;;; Searching
+;;;
+
+;;
+;; vector-index
+;;
+
+(with-test-prefix "vector-index"
+
+ (pass-if-equal "1 vector"
+ 2
+ (vector-index even? '#(3 1 4 1 6 9)))
+
+ (pass-if-equal "2 vectors, unequal lengths, success"
+ 1
+ (vector-index < '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
+
+ (pass-if-equal "2 vectors, unequal lengths, failure"
+ #f
+ (vector-index = '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
+
+ (pass-if-error "non-procedure"
+ (vector-index 1 '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
+
+ (pass-if-error "3 args, non-vector"
+ (vector-index = '#(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
+
+ (pass-if-error "4 args, non-vector"
+ (vector-index = '#(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2) '#(1 2 3)))
+
+ (pass-if-equal "3 vectors, unequal lengths, success"
+ 1
+ (vector-index <
+ '#(3 1 4 1 5 9 2 5 6)
+ '#(2 6 1 7 2)
+ '#(2 7 1 8)))
+
+ (pass-if-equal "3 vectors, unequal lengths, failure"
+ #f
+ (vector-index <
+ '#(3 1 4 1 5 9 2 5 6)
+ '#(2 7 1 7 2)
+ '#(2 7 1 7)))
+
+ (pass-if-equal "empty vector"
+ #f
+ (vector-index < '#() '#(2 7 1 8 2))))
+
+;;
+;; vector-index-right
+;;
+
+(with-test-prefix "vector-index-right"
+
+ (pass-if-equal "1 vector"
+ 4
+ (vector-index-right even? '#(3 1 4 1 6 9)))
+
+ (pass-if-equal "2 vectors, unequal lengths, success"
+ 3
+ (vector-index-right < '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
+
+ (pass-if-equal "2 vectors, unequal lengths, failure"
+ #f
+ (vector-index-right = '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
+
+ (pass-if-error "non-procedure"
+ (vector-index-right 1 '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
+
+ (pass-if-error "3 args, non-vector"
+ (vector-index-right = '#(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
+
+ (pass-if-error "4 args, non-vector"
+ (vector-index-right = '#(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2) '#(1 2 3)))
+
+ (pass-if-equal "3 vectors, unequal lengths, success"
+ 3
+ (vector-index-right <
+ '#(3 1 4 1 5 9 2 5 6)
+ '#(2 6 1 7 2)
+ '#(2 7 1 8)))
+
+ (pass-if-equal "3 vectors, unequal lengths, failure"
+ #f
+ (vector-index-right <
+ '#(3 1 4 1 5 9 2 5 6)
+ '#(2 7 1 7 2)
+ '#(2 7 1 7)))
+
+ (pass-if-equal "empty vector"
+ #f
+ (vector-index-right < '#() '#(2 7 1 8 2))))
+
+;;
+;; vector-skip
+;;
+
+(with-test-prefix "vector-skip"
+
+ (pass-if-equal "1 vector"
+ 2
+ (vector-skip odd? '#(3 1 4 1 6 9)))
+
+ (pass-if-equal "2 vectors, unequal lengths, success"
+ 1
+ (vector-skip >= '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
+
+ (pass-if-equal "2 vectors, unequal lengths, failure"
+ #f
+ (vector-skip (negate =) '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
+
+ (pass-if-error "non-procedure"
+ (vector-skip 1 '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
+
+ (pass-if-error "3 args, non-vector"
+ (vector-skip = '#(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
+
+ (pass-if-error "4 args, non-vector"
+ (vector-skip = '#(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2) '#(1 2 3)))
+
+ (pass-if-equal "3 vectors, unequal lengths, success"
+ 1
+ (vector-skip (negate <)
+ '#(3 1 4 1 5 9 2 5 6)
+ '#(2 6 1 7 2)
+ '#(2 7 1 8)))
+
+ (pass-if-equal "3 vectors, unequal lengths, failure"
+ #f
+ (vector-skip (negate <)
+ '#(3 1 4 1 5 9 2 5 6)
+ '#(2 7 1 7 2)
+ '#(2 7 1 7)))
+
+ (pass-if-equal "empty vector"
+ #f
+ (vector-skip (negate <) '#() '#(2 7 1 8 2))))
+
+;;
+;; vector-skip-right
+;;
+
+(with-test-prefix "vector-skip-right"
+
+ (pass-if-equal "1 vector"
+ 4
+ (vector-skip-right odd? '#(3 1 4 1 6 9)))
+
+ (pass-if-equal "2 vectors, unequal lengths, success"
+ 3
+ (vector-skip-right >= '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
+
+ (pass-if-equal "2 vectors, unequal lengths, failure"
+ #f
+ (vector-skip-right (negate =) '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
+
+ (pass-if-error "non-procedure"
+ (vector-skip-right 1 '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2)))
+
+ (pass-if-error "3 args, non-vector"
+ (vector-skip-right = '#(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2)))
+
+ (pass-if-error "4 args, non-vector"
+ (vector-skip-right = '#(3 1 4 1 5 9 2 5 6) '(2 7 1 8 2) '#(1 2 3)))
+
+ (pass-if-equal "3 vectors, unequal lengths, success"
+ 3
+ (vector-skip-right (negate <)
+ '#(3 1 4 1 5 9 2 5 6)
+ '#(2 6 1 7 2)
+ '#(2 7 1 8)))
+
+ (pass-if-equal "3 vectors, unequal lengths, failure"
+ #f
+ (vector-skip-right (negate <)
+ '#(3 1 4 1 5 9 2 5 6)
+ '#(2 7 1 7 2)
+ '#(2 7 1 7)))
+
+ (pass-if-equal "empty vector"
+ #f
+ (vector-skip-right (negate <) '#() '#(2 7 1 8 2))))
+
+;;
+;; vector-binary-search
+;;
+
+(with-test-prefix "vector-binary-search"
+
+ (define (char-cmp c1 c2)
+ (cond ((char<? c1 c2) -1)
+ ((char=? c1 c2) 0)
+ (else 1)))
+
+ (pass-if-equal "success"
+ 6
+ (vector-binary-search '#(#\a #\b #\c #\d #\e #\f #\g #\h)
+ #\g
+ char-cmp))
+
+ (pass-if-equal "failure"
+ #f
+ (vector-binary-search '#(#\a #\b #\c #\d #\e #\f #\g)
+ #\q
+ char-cmp))
+
+ (pass-if-equal "singleton vector, success"
+ 0
+ (vector-binary-search '#(#\a)
+ #\a
+ char-cmp))
+
+ (pass-if-equal "empty vector"
+ #f
+ (vector-binary-search '#()
+ #\a
+ char-cmp))
+
+ (pass-if-error "first element"
+ (vector-binary-search '(#\a #\b #\c)
+ #\a
+ char-cmp))
+
+ (pass-if-equal "specify range, success"
+ 3
+ (vector-binary-search '#(#\a #\b #\c #\d #\e #\f #\g #\h)
+ #\d
+ char-cmp
+ 2 6))
+
+ (pass-if-equal "specify range, failure"
+ #f
+ (vector-binary-search '#(#\a #\b #\c #\d #\e #\f #\g #\h)
+ #\g
+ char-cmp
+ 2 6)))
+
+;;
+;; vector-any
+;;
+
+(with-test-prefix "vector-any"
+
+ (pass-if-equal "1 vector, success"
+ #t
+ (vector-any even? '#(3 1 4 1 5 9 2)))
+
+ (pass-if-equal "1 vector, failure"
+ #f
+ (vector-any even? '#(3 1 5 1 5 9 1)))
+
+ (pass-if-equal "1 vector, left-to-right"
+ #t
+ (vector-any even? '#(3 1 4 1 5 #f 2)))
+
+ (pass-if-equal "1 vector, left-to-right"
+ 4
+ (vector-any (lambda (x) (and (even? x) x))
+ '#(3 1 4 1 5 #f 2)))
+
+ (pass-if-equal "1 empty vector"
+ #f
+ (vector-any even? '#()))
+
+ (pass-if-equal "2 vectors, unequal lengths, success"
+ '(1 2)
+ (vector-any (lambda (x y) (and (< x y) (list x y)))
+ '#(3 1 4 1 5 #f)
+ '#(1 0 1 2 3)))
+
+ (pass-if-equal "2 vectors, unequal lengths, failure"
+ #f
+ (vector-any < '#(3 1 4 1 5 #f) '#(1 0 1 0 3)))
+
+ (pass-if-equal "3 vectors, unequal lengths, success"
+ '(1 2 3)
+ (vector-any (lambda (x y z) (and (< x y z) (list x y z)))
+ '#(3 1 4 1 3 #f)
+ '#(1 0 1 2 4)
+ '#(2 1 6 3 5)))
+
+ (pass-if-equal "3 vectors, unequal lengths, failure"
+ #f
+ (vector-any <
+ '#(3 1 4 1 5 #f)
+ '#(1 0 3 2)
+ '#(2 1 6 2 3))))
+
+;;
+;; vector-every
+;;
+
+(with-test-prefix "vector-every"
+
+ (pass-if-equal "1 vector, failure"
+ #f
+ (vector-every odd? '#(3 1 4 1 5 9 2)))
+
+ (pass-if-equal "1 vector, success"
+ 11
+ (vector-every (lambda (x) (and (odd? x) x))
+ '#(3 5 7 1 5 9 11)))
+
+ (pass-if-equal "1 vector, left-to-right, failure"
+ #f
+ (vector-every odd? '#(3 1 4 1 5 #f 2)))
+
+ (pass-if-equal "1 empty vector"
+ #t
+ (vector-every even? '#()))
+
+ (pass-if-equal "2 vectors, unequal lengths, left-to-right, failure"
+ #f
+ (vector-every >= '#(3 1 4 1 5) '#(1 0 1 2 3 #f)))
+
+ (pass-if-equal "2 vectors, unequal lengths, left-to-right, success"
+ '(5 3)
+ (vector-every (lambda (x y) (and (>= x y) (list x y)))
+ '#(3 1 4 1 5)
+ '#(1 0 1 0 3 #f)))
+
+ (pass-if-equal "3 vectors, unequal lengths, left-to-right, failure"
+ #f
+ (vector-every >=
+ '#(3 1 4 1 5)
+ '#(1 0 1 2 3 #f)
+ '#(0 0 1 2)))
+
+ (pass-if-equal "3 vectors, unequal lengths, left-to-right, success"
+ '(8 5 4)
+ (vector-every (lambda (x y z) (and (>= x y z) (list x y z)))
+ '#(3 5 4 8 5)
+ '#(2 3 4 5 3 #f)
+ '#(1 2 3 4))))
+
+;;;
+;;; Mutators
+;;;
+
+;;
+;; vector-set!
+;;
+
+(with-test-prefix "vector-set!"
+
+ (pass-if-equal "simple"
+ '#(0 a 2)
+ (let ((v (vector 0 1 2)))
+ (vector-set! v 1 'a)
+ v))
+
+ (pass-if-error "index beyond end" (vector-set! (vector 0 1 2) 3 'a))
+ (pass-if-error "negative index" (vector-set! (vector 0 1 2) -1 'a))
+ (pass-if-error "empty vector" (vector-set! (vector) 0 'a)))
+
+;;
+;; vector-swap!
+;;
+
+(with-test-prefix "vector-swap!"
+
+ (pass-if-equal "simple"
+ '#(b a c)
+ (let ((v (vector 'a 'b 'c)))
+ (vector-swap! v 0 1)
+ v))
+
+ (pass-if-equal "same index"
+ '#(a b c)
+ (let ((v (vector 'a 'b 'c)))
+ (vector-swap! v 1 1)
+ v))
+
+ (pass-if-error "index beyond end" (vector-swap! (vector 'a 'b 'c) 0 3))
+ (pass-if-error "negative index" (vector-swap! (vector 'a 'b 'c) -1 1))
+ (pass-if-error "empty vector" (vector-swap! (vector) 0 0)))
+
+;;
+;; vector-fill!
+;;
+
+(with-test-prefix "vector-fill!"
+
+ (pass-if-equal "2 args"
+ '#(z z z z z)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-fill! v 'z)
+ v))
+
+ (pass-if-equal "3 args"
+ '#(a b z z z)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-fill! v 'z 2)
+ v))
+
+ (pass-if-equal "4 args"
+ '#(a z z d e)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-fill! v 'z 1 3)
+ v))
+
+ (pass-if-equal "4 args, entire vector"
+ '#(z z z z z)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-fill! v 'z 0 5)
+ v))
+
+ (pass-if-equal "4 args, empty range"
+ '#(a b c d e)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-fill! v 'z 2 2)
+ v))
+
+ (pass-if-error "index beyond end" (vector-fill! (vector 'a 'b 'c) 'z 0 4))
+ (pass-if-error "invalid range" (vector-fill! (vector 'a 'b 'c) 'z 2 1))
+ (pass-if-error "negative index" (vector-fill! (vector 'a 'b 'c) 'z -1 1))
+
+ ;; This is intentionally allowed in Guile, as an extension:
+ ;;(pass-if-error "vector-fill! e3" (vector-fill! (vector) 'z 0 0))
+ )
+
+;;
+;; vector-reverse!
+;;
+
+(with-test-prefix "vector-reverse!"
+
+ (pass-if-equal "1 arg"
+ '#(e d c b a)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-reverse! v)
+ v))
+
+ (pass-if-equal "2 args"
+ '#(a b f e d c)
+ (let ((v (vector 'a 'b 'c 'd 'e 'f)))
+ (vector-reverse! v 2)
+ v))
+
+ (pass-if-equal "3 args"
+ '#(a d c b e f)
+ (let ((v (vector 'a 'b 'c 'd 'e 'f)))
+ (vector-reverse! v 1 4)
+ v))
+
+ (pass-if-equal "3 args, empty range"
+ '#(a b c d e f)
+ (let ((v (vector 'a 'b 'c 'd 'e 'f)))
+ (vector-reverse! v 3 3)
+ v))
+
+ (pass-if-equal "3 args, singleton range"
+ '#(a b c d e f)
+ (let ((v (vector 'a 'b 'c 'd 'e 'f)))
+ (vector-reverse! v 3 4)
+ v))
+
+ (pass-if-equal "empty vector"
+ '#()
+ (let ((v (vector)))
+ (vector-reverse! v)
+ v))
+
+ (pass-if-error "index beyond end" (vector-reverse! (vector 'a 'b) 0 3))
+ (pass-if-error "invalid range" (vector-reverse! (vector 'a 'b) 2 1))
+ (pass-if-error "negative index" (vector-reverse! (vector 'a 'b) -1 1))
+
+ ;; This is intentionally allowed in Guile, as an extension:
+ ;;(pass-if-error "vector-reverse! e3" (vector-reverse! (vector) 0 0))
+ )
+
+;;
+;; vector-copy!
+;;
+
+(with-test-prefix "vector-copy!"
+
+ (pass-if-equal "3 args, 0 tstart"
+ '#(1 2 3 d e)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-copy! v 0 '#(1 2 3))
+ v))
+
+ (pass-if-equal "3 args, 2 tstart"
+ '#(a b 1 2 3)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-copy! v 2 '#(1 2 3))
+ v))
+
+ (pass-if-equal "4 args"
+ '#(a b 2 3 e)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-copy! v 2 '#(1 2 3) 1)
+ v))
+
+ (pass-if-equal "5 args"
+ '#(a b 3 4 5)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-copy! v 2 '#(1 2 3 4 5) 2 5)
+ v))
+
+ (pass-if-equal "5 args, empty range"
+ '#(a b c d e)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-copy! v 2 '#(1 2 3) 1 1)
+ v))
+
+ (pass-if-equal "overlapping source/target, moving right"
+ '#(b c c d e)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-copy! v 0 v 1 3)
+ v))
+
+ (pass-if-equal "overlapping source/target, moving left"
+ '#(a b b c d)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-copy! v 2 v 1 4)
+ v))
+
+ (pass-if-equal "overlapping source/target, not moving"
+ '#(a b c d e)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-copy! v 0 v 0)
+ v))
+
+ (pass-if-error "tstart beyond end"
+ (vector-copy! (vector 1 2) 3 '#(1 2 3)))
+ (pass-if-error "would overwrite target end"
+ (vector-copy! (vector 1 2) 0 '#(1 2 3)))
+ (pass-if-error "would overwrite target end"
+ (vector-copy! (vector 1 2) 1 '#(1 2 3) 1)))
+
+;;
+;; vector-reverse-copy!
+;;
+
+(with-test-prefix "vector-reverse-copy!"
+
+ (pass-if-equal "3 args, 0 tstart"
+ '#(3 2 1 d e)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-reverse-copy! v 0 '#(1 2 3))
+ v))
+
+ (pass-if-equal "3 args, 2 tstart"
+ '#(a b 3 2 1)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-reverse-copy! v 2 '#(1 2 3))
+ v))
+
+ (pass-if-equal "4 args"
+ '#(a b 3 2 e)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-reverse-copy! v 2 '#(1 2 3) 1)
+ v))
+
+ (pass-if-equal "5 args"
+ '#(a b 4 3 2)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-reverse-copy! v 2 '#(1 2 3 4 5) 1 4)
+ v))
+
+ (pass-if-equal "5 args, empty range"
+ '#(a b c d e)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-reverse-copy! v 2 '#(1 2 3 4 5) 2 2)
+ v))
+
+ (pass-if-equal "3 args, overlapping source/target"
+ '#(e d c b a)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-reverse-copy! v 0 v)
+ v))
+
+ (pass-if-equal "5 args, overlapping source/target"
+ '#(b a c d e)
+ (let ((v (vector 'a 'b 'c 'd 'e)))
+ (vector-reverse-copy! v 0 v 0 2)
+ v))
+
+ (pass-if-error "3 args, would overwrite target end"
+ (vector-reverse-copy! (vector 'a 'b) 2 '#(a b)))
+ (pass-if-error "3 args, negative tstart"
+ (vector-reverse-copy! (vector 'a 'b) -1 '#(a b)))
+ (pass-if-error "3 args, would overwrite target end"
+ (vector-reverse-copy! (vector 'a 'b) 0 '#(a b c)))
+ (pass-if-error "5 args, send beyond end"
+ (vector-reverse-copy! (vector 'a 'b) 0 '#(a b c) 1 4))
+ (pass-if-error "5 args, negative sstart"
+ (vector-reverse-copy! (vector 'a 'b) 0 '#(a b c) -1 2))
+ (pass-if-error "5 args, invalid source range"
+ (vector-reverse-copy! (vector 'a 'b) 0 '#(a b c) 2 1)))
+
+;;;
+;;; Conversion
+;;;
+
+;;
+;; vector->list
+;;
+
+(with-test-prefix "vector->list"
+
+ (pass-if-equal "1 arg"
+ '(a b c)
+ (vector->list '#(a b c)))
+
+ (pass-if-equal "2 args"
+ '(b c)
+ (vector->list '#(a b c) 1))
+
+ (pass-if-equal "3 args"
+ '(b c d)
+ (vector->list '#(a b c d e) 1 4))
+
+ (pass-if-equal "3 args, empty range"
+ '()
+ (vector->list '#(a b c d e) 1 1))
+
+ (pass-if-equal "1 arg, empty vector"
+ '()
+ (vector->list '#()))
+
+ (pass-if-error "index beyond end" (vector->list '#(a b c) 1 6))
+ (pass-if-error "negative index" (vector->list '#(a b c) -1 1))
+ (pass-if-error "invalid range" (vector->list '#(a b c) 2 1)))
+
+;;
+;; reverse-vector->list
+;;
+
+(with-test-prefix "reverse-vector->list"
+
+ (pass-if-equal "1 arg"
+ '(c b a)
+ (reverse-vector->list '#(a b c)))
+
+ (pass-if-equal "2 args"
+ '(c b)
+ (reverse-vector->list '#(a b c) 1))
+
+ (pass-if-equal "3 args"
+ '(d c b)
+ (reverse-vector->list '#(a b c d e) 1 4))
+
+ (pass-if-equal "3 args, empty range"
+ '()
+ (reverse-vector->list '#(a b c d e) 1 1))
+
+ (pass-if-equal "1 arg, empty vector"
+ '()
+ (reverse-vector->list '#()))
+
+ (pass-if-error "index beyond end" (reverse-vector->list '#(a b c) 1 6))
+ (pass-if-error "negative index" (reverse-vector->list '#(a b c) -1 1))
+ (pass-if-error "invalid range" (reverse-vector->list '#(a b c) 2 1)))
+
+;;
+;; list->vector
+;;
+
+(with-test-prefix "list->vector"
+
+ (pass-if-equal "1 arg"
+ '#(a b c)
+ (list->vector '(a b c)))
+
+ (pass-if-equal "1 empty list"
+ '#()
+ (list->vector '()))
+
+ (pass-if-equal "2 args"
+ '#(2 3)
+ (list->vector '(0 1 2 3) 2))
+
+ (pass-if-equal "3 args"
+ '#(0 1)
+ (list->vector '(0 1 2 3) 0 2))
+
+ (pass-if-equal "3 args, empty range"
+ '#()
+ (list->vector '(0 1 2 3) 2 2))
+
+ (pass-if-error "index beyond end" (list->vector '(0 1 2 3) 0 5))
+ (pass-if-error "negative index" (list->vector '(0 1 2 3) -1 1))
+ (pass-if-error "invalid range" (list->vector '(0 1 2 3) 2 1)))
+
+;;
+;; reverse-list->vector
+;;
+
+(with-test-prefix "reverse-list->vector"
+
+ (pass-if-equal "1 arg"
+ '#(c b a)
+ (reverse-list->vector '(a b c)))
+
+ (pass-if-equal "1 empty list"
+ '#()
+ (reverse-list->vector '()))
+
+ (pass-if-equal "2 args"
+ '#(3 2)
+ (reverse-list->vector '(0 1 2 3) 2))
+
+ (pass-if-equal "3 args"
+ '#(1 0)
+ (reverse-list->vector '(0 1 2 3) 0 2))
+
+ (pass-if-equal "3 args, empty range"
+ '#()
+ (reverse-list->vector '(0 1 2 3) 2 2))
+
+ (pass-if-error "index beyond end"
+ (reverse-list->vector '(0 1 2 3) 0 5))
+
+ (pass-if-error "negative index"
+ (reverse-list->vector '(0 1 2 3) -1 1))
+
+ (pass-if-error "invalid range"
+ (reverse-list->vector '(0 1 2 3) 2 1)))
+
+;;; Local Variables:
+;;; eval: (put 'pass-if-error 'scheme-indent-function 1)
+;;; End:
diff --git a/test-suite/tests/srfi-64-test.scm
b/test-suite/tests/srfi-64-test.scm
new file mode 100644
index 0000000..3cd67d0
--- /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 0000000..190d6b2
--- /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:
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, stable-2.0, updated. v2.0.9-178-g34e8987,
Mark H Weaver <=