mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-30 11:50:28 +02:00
Code Activity

Merge commit '34e8987734'

Browse source 
Conflicts:
	module/Makefile.am
This commit is contained in:
Andy Wingo 2014-02-07 15:13:22 +01:00
commit cd36c69619
9 changed files with 4957 additions and 2 deletions
Download patch file Download diff file Expand all files Collapse all files

420
doc/ref/srfi-modules.texi
View file

@ -47,12 +47,14 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-39:: Parameter objects * SRFI-39:: Parameter objects
* SRFI-41:: Streams. * SRFI-41:: Streams.
* SRFI-42:: Eager comprehensions * SRFI-42:: Eager comprehensions
* SRFI-43:: Vector Library.
* SRFI-45:: Primitives for expressing iterative lazy algorithms * SRFI-45:: Primitives for expressing iterative lazy algorithms
* SRFI-46:: Basic syntax-rules Extensions. * SRFI-46:: Basic syntax-rules Extensions.
* SRFI-55:: Requiring Features. * SRFI-55:: Requiring Features.
* SRFI-60:: Integers as bits. * SRFI-60:: Integers as bits.
* SRFI-61:: A more general `cond' clause * SRFI-61:: A more general `cond' clause
* SRFI-62:: S-expression comments. * SRFI-62:: S-expression comments.
* SRFI-64:: A Scheme API for test suites.
* SRFI-67:: Compare procedures * SRFI-67:: Compare procedures
* SRFI-69:: Basic hash tables. * SRFI-69:: Basic hash tables.
* SRFI-87:: => in case clauses. * SRFI-87:: => in case clauses.
@ -4504,6 +4506,417 @@ the input @var{stream}s is finite, or is infinite if all the input
See @uref{http://srfi.schemers.org/srfi-42/srfi-42.html, the See @uref{http://srfi.schemers.org/srfi-42/srfi-42.html, the
specification of SRFI-42}. specification of SRFI-42}.
@node SRFI-43
@subsection SRFI-43 - Vector Library
@cindex SRFI-43
This subsection is based on the
@uref{http://srfi.schemers.org/srfi-43/srfi-43.html, specification of
SRFI-43} by Taylor Campbell.
@c The copyright notice and license text of the SRFI-43 specification is
@c reproduced below:
@c Copyright (C) Taylor Campbell (2003). All Rights Reserved.
@c Permission is hereby granted, free of charge, to any person obtaining a
@c copy of this software and associated documentation files (the
@c "Software"), to deal in the Software without restriction, including
@c without limitation the rights to use, copy, modify, merge, publish,
@c distribute, sublicense, and/or sell copies of the Software, and to
@c permit persons to whom the Software is furnished to do so, subject to
@c the following conditions:
@c The above copyright notice and this permission notice shall be included
@c in all copies or substantial portions of the Software.
@c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
@c OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
@c MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
@c NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
@c LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
@c OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
@c WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
@noindent
SRFI-43 implements a comprehensive library of vector operations. It can
be made available with:
@example
(use-modules (srfi srfi-43))
@end example
@menu
* SRFI-43 Constructors::
* SRFI-43 Predicates::
* SRFI-43 Selectors::
* SRFI-43 Iteration::
* SRFI-43 Searching::
* SRFI-43 Mutators::
* SRFI-43 Conversion::
@end menu
@node SRFI-43 Constructors
@subsubsection SRFI-43 Constructors
@deffn {Scheme Procedure} make-vector size [fill]
Create and return a vector of size @var{size}, optionally filling it
with @var{fill}. The default value of @var{fill} is unspecified.
@example
(make-vector 5 3) @result{} #(3 3 3 3 3)
@end example
@end deffn
@deffn {Scheme Procedure} vector x @dots{}
Create and return a vector whose elements are @var{x} @enddots{}.
@example
(vector 0 1 2 3 4) @result{} #(0 1 2 3 4)
@end example
@end deffn
@deffn {Scheme Procedure} vector-unfold f length initial-seed @dots{}
The fundamental vector constructor. Create a vector whose length is
@var{length} and iterates across each index k from 0 up to
@var{length} - 1, applying @var{f} at each iteration to the current index
and current seeds, in that order, to receive n + 1 values: first, the
element to put in the kth slot of the new vector and n new seeds for
the next iteration. It is an error for the number of seeds to vary
between iterations.
@example
(vector-unfold (lambda (i x) (values x (- x 1)))
10 0)
@result{} #(0 -1 -2 -3 -4 -5 -6 -7 -8 -9)
(vector-unfold values 10)
@result{} #(0 1 2 3 4 5 6 7 8 9)
@end example
@end deffn
@deffn {Scheme Procedure} vector-unfold-right f length initial-seed @dots{}
Like @code{vector-unfold}, but it uses @var{f} to generate elements from
right-to-left, rather than left-to-right.
@example
(vector-unfold-right (lambda (i x) (values x (+ x 1)))
10 0)
@result{} #(9 8 7 6 5 4 3 2 1 0)
@end example
@end deffn
@deffn {Scheme Procedure} vector-copy vec [start [end [fill]]]
Allocate a new vector whose length is @var{end} - @var{start} and fills
it with elements from @var{vec}, taking elements from @var{vec} starting
at index @var{start} and stopping at index @var{end}. @var{start}
defaults to 0 and @var{end} defaults to the value of
@code{(vector-length vec)}. If @var{end} extends beyond the length of
@var{vec}, the slots in the new vector that obviously cannot be filled
by elements from @var{vec} are filled with @var{fill}, whose default
value is unspecified.
@example
(vector-copy '#(a b c d e f g h i))
@result{} #(a b c d e f g h i)
(vector-copy '#(a b c d e f g h i) 6)
@result{} #(g h i)
(vector-copy '#(a b c d e f g h i) 3 6)
@result{} #(d e f)
(vector-copy '#(a b c d e f g h i) 6 12 'x)
@result{} #(g h i x x x)
@end example
@end deffn
@deffn {Scheme Procedure} vector-reverse-copy vec [start [end]]
Like @code{vector-copy}, but it copies the elements in the reverse order
from @var{vec}.
@example
(vector-reverse-copy '#(5 4 3 2 1 0) 1 5)
@result{} #(1 2 3 4)
@end example
@end deffn
@deffn {Scheme Procedure} vector-append vec @dots{}
Return a newly allocated vector that contains all elements in order from
the subsequent locations in @var{vec} @enddots{}.
@example
(vector-append '#(a) '#(b c d))
@result{} #(a b c d)
@end example
@end deffn
@deffn {Scheme Procedure} vector-concatenate list-of-vectors
Append each vector in @var{list-of-vectors}. Equivalent to
@code{(apply vector-append list-of-vectors)}.
@example
(vector-concatenate '(#(a b) #(c d)))
@result{} #(a b c d)
@end example
@end deffn
@node SRFI-43 Predicates
@subsubsection SRFI-43 Predicates
@deffn {Scheme Procedure} vector? obj
Return true if @var{obj} is a vector, else return false.
@end deffn
@deffn {Scheme Procedure} vector-empty? vec
Return true if @var{vec} is empty, i.e. its length is 0, else return
false.
@end deffn
@deffn {Scheme Procedure} vector= elt=? vec @dots{}
Return true if the vectors @var{vec} @dots{} have equal lengths and
equal elements according to @var{elt=?}. @var{elt=?} is always applied
to two arguments. Element comparison must be consistent with @code{eq?}
in the following sense: if @code{(eq? a b)} returns true, then
@code{(elt=? a b)} must also return true. The order in which
comparisons are performed is unspecified.
@end deffn
@node SRFI-43 Selectors
@subsubsection SRFI-43 Selectors
@deffn {Scheme Procedure} vector-ref vec i
Return the value that the location in @var{vec} at @var{i} is mapped to
in the store. Indexing is based on zero.
@end deffn
@deffn {Scheme Procedure} vector-length vec
Return the length of @var{vec}.
@end deffn
@node SRFI-43 Iteration
@subsubsection SRFI-43 Iteration
@deffn {Scheme Procedure} vector-fold kons knil vec1 vec2 @dots{}
The fundamental vector iterator. @var{kons} is iterated over each index
in all of the vectors, stopping at the end of the shortest; @var{kons}
is applied as
@smalllisp
(kons i state (vector-ref vec1 i) (vector-ref vec2 i) ...)
@end smalllisp
where @var{state} is the current state value, and @var{i} is the current
index. The current state value begins with @var{knil}, and becomes
whatever @var{kons} returned at the respective iteration. The iteration
is strictly left-to-right.
@end deffn
@deffn {Scheme Procedure} vector-fold-right kons knil vec1 vec2 @dots{}
Similar to @code{vector-fold}, but it iterates right-to-left instead of
left-to-right.
@end deffn
@deffn {Scheme Procedure} vector-map f vec1 vec2 @dots{}
Return a new vector of the shortest size of the vector arguments. Each
element at index i of the new vector is mapped from the old vectors by
@smalllisp
(f i (vector-ref vec1 i) (vector-ref vec2 i) ...)
@end smalllisp
The dynamic order of application of @var{f} is unspecified.
@end deffn
@deffn {Scheme Procedure} vector-map! f vec1 vec2 @dots{}
Similar to @code{vector-map}, but rather than mapping the new elements
into a new vector, the new mapped elements are destructively inserted
into @var{vec1}. The dynamic order of application of @var{f} is
unspecified.
@end deffn
@deffn {Scheme Procedure} vector-for-each f vec1 vec2 @dots{}
Call @code{(f i (vector-ref vec1 i) (vector-ref vec2 i) ...)} for each
index i less than the length of the shortest vector passed. The
iteration is strictly left-to-right.
@end deffn
@deffn {Scheme Procedure} vector-count pred? vec1 vec2 @dots{}
Count the number of parallel elements in the vectors that satisfy
@var{pred?}, which is applied, for each index i less than the length of
the smallest vector, to i and each parallel element in the vectors at
that index, in order.
@example
(vector-count (lambda (i elt) (even? elt))
'#(3 1 4 1 5 9 2 5 6))
@result{} 3
(vector-count (lambda (i x y) (< x y))
'#(1 3 6 9) '#(2 4 6 8 10 12))
@result{} 2
@end example
@end deffn
@node SRFI-43 Searching
@subsubsection SRFI-43 Searching
@deffn {Scheme Procedure} vector-index pred? vec1 vec2 @dots{}
Find and return the index of the first elements in @var{vec1} @var{vec2}
@dots{} that satisfy @var{pred?}. If no matching element is found by
the end of the shortest vector, return @code{#f}.
@example
(vector-index even? '#(3 1 4 1 5 9))
@result{} 2
(vector-index < '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2))
@result{} 1
(vector-index = '#(3 1 4 1 5 9 2 5 6) '#(2 7 1 8 2))
@result{} #f
@end example
@end deffn
@deffn {Scheme Procedure} vector-index-right pred? vec1 vec2 @dots{}
Like @code{vector-index}, but it searches right-to-left, rather than
left-to-right. Note that the SRFI 43 specification requires that all
the vectors must have the same length, but both the SRFI 43 reference
implementation and Guile's implementation allow vectors with unequal
lengths, and start searching from the last index of the shortest vector.
@end deffn
@deffn {Scheme Procedure} vector-skip pred? vec1 vec2 @dots{}
Find and return the index of the first elements in @var{vec1} @var{vec2}
@dots{} that do not satisfy @var{pred?}. If no matching element is
found by the end of the shortest vector, return @code{#f}. Equivalent
to @code{vector-index} but with the predicate inverted.
@example
(vector-skip number? '#(1 2 a b 3 4 c d)) @result{} 2
@end example
@end deffn
@deffn {Scheme Procedure} vector-skip-right pred? vec1 vec2 @dots{}
Like @code{vector-skip}, but it searches for a non-matching element
right-to-left, rather than left-to-right. Note that the SRFI 43
specification requires that all the vectors must have the same length,
but both the SRFI 43 reference implementation and Guile's implementation
allow vectors with unequal lengths, and start searching from the last
index of the shortest vector.
@end deffn
@deffn {Scheme Procedure} vector-binary-search vec value cmp [start [end]]
Find and return an index of @var{vec} between @var{start} and @var{end}
whose value is @var{value} using a binary search. If no matching
element is found, return @code{#f}. The default @var{start} is 0 and
the default @var{end} is the length of @var{vec}.
@var{cmp} must be a procedure of two arguments such that @code{(cmp a
b)} returns a negative integer if @math{a < b}, a positive integer if
@math{a > b}, or zero if @math{a = b}. The elements of @var{vec} must
be sorted in non-decreasing order according to @var{cmp}.
Note that SRFI 43 does not document the @var{start} and @var{end}
arguments, but both its reference implementation and Guile's
implementation support them.
@example
(define (char-cmp c1 c2)
(cond ((char<? c1 c2) -1)
((char>? c1 c2) 1)
(else 0)))
(vector-binary-search '#(#\a #\b #\c #\d #\e #\f #\g #\h)
#\g
char-cmp)
@result{} 6
@end example
@end deffn
@deffn {Scheme Procedure} vector-any pred? vec1 vec2 @dots{}
Find the first parallel set of elements from @var{vec1} @var{vec2}
@dots{} for which @var{pred?} returns a true value. If such a parallel
set of elements exists, @code{vector-any} returns the value that
@var{pred?} returned for that set of elements. The iteration is
strictly left-to-right.
@end deffn
@deffn {Scheme Procedure} vector-every pred? vec1 vec2 @dots{}
If, for every index i between 0 and the length of the shortest vector
argument, the set of elements @code{(vector-ref vec1 i)}
@code{(vector-ref vec2 i)} @dots{} satisfies @var{pred?},
@code{vector-every} returns the value that @var{pred?} returned for the
last set of elements, at the last index of the shortest vector.
Otherwise it returns @code{#f}. The iteration is strictly
left-to-right.
@end deffn
@node SRFI-43 Mutators
@subsubsection SRFI-43 Mutators
@deffn {Scheme Procedure} vector-set! vec i value
Assign the contents of the location at @var{i} in @var{vec} to
@var{value}.
@end deffn
@deffn {Scheme Procedure} vector-swap! vec i j
Swap the values of the locations in @var{vec} at @var{i} and @var{j}.
@end deffn
@deffn {Scheme Procedure} vector-fill! vec fill [start [end]]
Assign the value of every location in @var{vec} between @var{start} and
@var{end} to @var{fill}. @var{start} defaults to 0 and @var{end}
defaults to the length of @var{vec}.
@end deffn
@deffn {Scheme Procedure} vector-reverse! vec [start [end]]
Destructively reverse the contents of @var{vec} between @var{start} and
@var{end}. @var{start} defaults to 0 and @var{end} defaults to the
length of @var{vec}.
@end deffn
@deffn {Scheme Procedure} vector-copy! target tstart source [sstart [send]]
Copy a block of elements from @var{source} to @var{target}, both of
which must be vectors, starting in @var{target} at @var{tstart} and
starting in @var{source} at @var{sstart}, ending when (@var{send} -
@var{sstart}) elements have been copied. It is an error for
@var{target} to have a length less than (@var{tstart} + @var{send} -
@var{sstart}). @var{sstart} defaults to 0 and @var{send} defaults to
the length of @var{source}.
@end deffn
@deffn {Scheme Procedure} vector-reverse-copy! target tstart source [sstart [send]]
Like @code{vector-copy!}, but this copies the elements in the reverse
order. It is an error if @var{target} and @var{source} are identical
vectors and the @var{target} and @var{source} ranges overlap; however,
if @var{tstart} = @var{sstart}, @code{vector-reverse-copy!} behaves as
@code{(vector-reverse! target tstart send)} would.
@end deffn
@node SRFI-43 Conversion
@subsubsection SRFI-43 Conversion
@deffn {Scheme Procedure} vector->list vec [start [end]]
Return a newly allocated list containing the elements in @var{vec}
between @var{start} and @var{end}. @var{start} defaults to 0 and
@var{end} defaults to the length of @var{vec}.
@end deffn
@deffn {Scheme Procedure} reverse-vector->list vec [start [end]]
Like @code{vector->list}, but the resulting list contains the specified
range of elements of @var{vec} in reverse order.
@end deffn
@deffn {Scheme Procedure} list->vector proper-list [start [end]]
Return a newly allocated vector of the elements from @var{proper-list}
with indices between @var{start} and @var{end}. @var{start} defaults to
0 and @var{end} defaults to the length of @var{proper-list}. Note that
SRFI 43 does not document the @var{start} and @var{end} arguments, but
both its reference implementation and Guile's implementation support
them.
@end deffn
@deffn {Scheme Procedure} reverse-list->vector proper-list [start [end]]
Like @code{list->vector}, but the resulting vector contains the specified
range of elements of @var{proper-list} in reverse order. Note that SRFI
43 does not document the @var{start} and @var{end} arguments, but both
its reference implementation and Guile's implementation support them.
@end deffn
@node SRFI-45 @node SRFI-45
@subsection SRFI-45 - Primitives for Expressing Iterative Lazy Algorithms @subsection SRFI-45 - Primitives for Expressing Iterative Lazy Algorithms
@cindex SRFI-45 @cindex SRFI-45
@ -4852,6 +5265,13 @@ needed to get SRFI-61 itself. Extended @code{cond} is documented in
Starting from version 2.0, Guile's @code{read} supports SRFI-62/R7RS Starting from version 2.0, Guile's @code{read} supports SRFI-62/R7RS
S-expression comments by default. S-expression comments by default.
@node SRFI-64
@subsection SRFI-64 - A Scheme API for test suites.
@cindex SRFI-64
See @uref{http://srfi.schemers.org/srfi-64/srfi-64.html, the
specification of SRFI-64}.
@node SRFI-67 @node SRFI-67
@subsection SRFI-67 - Compare procedures @subsection SRFI-67 - Compare procedures
@cindex SRFI-67 @cindex SRFI-67

8
module/Makefile.am
View file

@ -1,6 +1,7 @@
## Process this file with automake to produce Makefile.in. ## Process this file with automake to produce Makefile.in.
## ##
## Copyright (C) 2009, 2010, 2011, 2012, 2013, 2014 Free Software Foundation, Inc. ## Copyright (C) 2009, 2010, 2011, 2012, 2013,
## 2014 Free Software Foundation, Inc.
## ##
## This file is part of GUILE. ## This file is part of GUILE.
## ##
@ -279,6 +280,8 @@ SCRIPTS_SOURCES += \
endif BUILD_ICE_9_POPEN endif BUILD_ICE_9_POPEN
srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm
SRFI_SOURCES = \ SRFI_SOURCES = \
srfi/srfi-2.scm \ srfi/srfi-2.scm \
srfi/srfi-4.scm \ srfi/srfi-4.scm \
@ -304,9 +307,11 @@ SRFI_SOURCES = \
srfi/srfi-38.scm \ srfi/srfi-38.scm \
srfi/srfi-41.scm \ srfi/srfi-41.scm \
srfi/srfi-42.scm \ srfi/srfi-42.scm \
srfi/srfi-43.scm \
srfi/srfi-39.scm \ srfi/srfi-39.scm \
srfi/srfi-45.scm \ srfi/srfi-45.scm \
srfi/srfi-60.scm \ srfi/srfi-60.scm \
srfi/srfi-64.scm \
srfi/srfi-67.scm \ srfi/srfi-67.scm \
srfi/srfi-69.scm \ srfi/srfi-69.scm \
srfi/srfi-88.scm \ srfi/srfi-88.scm \
@ -418,6 +423,7 @@ NOCOMP_SOURCES = \
ice-9/r6rs-libraries.scm \ ice-9/r6rs-libraries.scm \
ice-9/quasisyntax.scm \ ice-9/quasisyntax.scm \
srfi/srfi-42/ec.scm \ srfi/srfi-42/ec.scm \
srfi/srfi-64/testing.scm \
srfi/srfi-67/compare.scm \ srfi/srfi-67/compare.scm \
system/base/lalr.upstream.scm \ system/base/lalr.upstream.scm \
system/repl/describe.scm \ system/repl/describe.scm \

1077
module/srfi/srfi-43.scm Normal file
View file

File diff suppressed because it is too large Load diff

55
module/srfi/srfi-64.scm Normal file
View file

@ -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")

1040
module/srfi/srfi-64/testing.scm Normal file
View file

File diff suppressed because it is too large Load diff

5
test-suite/Makefile.am
View file

@ -137,8 +137,10 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-39.test \ tests/srfi-39.test \
tests/srfi-41.test \ tests/srfi-41.test \
tests/srfi-42.test \ tests/srfi-42.test \
tests/srfi-43.test \
tests/srfi-45.test \ tests/srfi-45.test \
tests/srfi-60.test \ tests/srfi-60.test \
tests/srfi-64.test \
tests/srfi-67.test \ tests/srfi-67.test \
tests/srfi-69.test \ tests/srfi-69.test \
tests/srfi-88.test \ tests/srfi-88.test \
@ -177,7 +179,8 @@ EXTRA_DIST = \
guile-test \ guile-test \
test-suite/lib.scm \ test-suite/lib.scm \
$(SCM_TESTS) \ $(SCM_TESTS) \
tests/rnrs-test-a.scm tests/rnrs-test-a.scm \
tests/srfi-64-test.scm \
ChangeLog-2008 ChangeLog-2008

1375
test-suite/tests/srfi-43.test Normal file
View file

File diff suppressed because it is too large Load diff

934
test-suite/tests/srfi-64-test.scm Normal file
View file

@ -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")
;;;

45
test-suite/tests/srfi-64.test Normal file
View file

@ -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: