diff --git a/am/bootstrap.am b/am/bootstrap.am index 9e5fca0db..d4a415e35 100644 --- a/am/bootstrap.am +++ b/am/bootstrap.am @@ -54,7 +54,6 @@ COMPILE = $(AM_V_GUILEC) \ ice-9/boot-9.go: ice-9/boot-9.scm ice-9/quasisyntax.scm ice-9/r6rs-libraries.scm ice-9/r7rs-libraries.scm ice-9/read.scm ice-9/match.go: ice-9/match.scm ice-9/match.upstream.scm -srfi/srfi-64.go: srfi/srfi-64.scm srfi/srfi-64/testing.scm # Keep this rule in sync with that in `am/guilec'. ice-9/psyntax-pp.go: ice-9/psyntax.scm ice-9/psyntax-pp.scm @@ -438,7 +437,6 @@ NOCOMP_SOURCES = \ ice-9/r7rs-libraries.scm \ ice-9/quasisyntax.scm \ srfi/srfi-42/ec.scm \ - srfi/srfi-64/testing.scm \ srfi/srfi-67/compare.scm \ system/base/lalr.upstream.scm \ system/repl/describe.scm \ diff --git a/module/srfi/srfi-64.scm b/module/srfi/srfi-64.scm index 925726f5c..1f60a72e5 100644 --- a/module/srfi/srfi-64.scm +++ b/module/srfi/srfi-64.scm @@ -1,6 +1,5 @@ -;;; srfi-64.scm -- SRFI 64 - A Scheme API for test suites. +;;; Copyright (C) 2024 Tomas Volf <~@wolfsden.cz> -;; 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 @@ -16,41 +15,983 @@ ;; License along with this library; if not, write to the Free Software ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA +;;; Commentary: + +;;; Implementation of the SRFI-64. In contrast to the reference +;;; implementation of @samp{(srfi srfi-64)} it aims to implement the +;;; standard fully and correctly. + +;;; Code: + (define-module (srfi srfi-64) + #:use-module (ice-9 exceptions) + #:use-module (ice-9 format) + #:use-module (ice-9 match) + #:use-module (ice-9 pretty-print) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) #: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) - #:declarative? #f) ; #f needed for test-log-to-file + ( + ;; Going by individual sections of the specification, top to bottom: + ;; Simple test-cases + test-approximate + test-assert + test-eq + test-equal + test-eqv + ;; Tests for catching errors + test-error + ;; Testing syntax + test-read-eval-string + ;; Test groups and paths + test-begin + test-end + test-group + ;; Handling set-up and cleanup + test-group-with-cleanup + ;; Test specifiers + test-match-all + test-match-any + test-match-name + test-match-nth + ;; Skipping selected tests + test-expect-fail + test-skip + ;; Test-runner + test-runner-create + test-runner-current + test-runner-factory + test-runner-get + test-runner-null + test-runner-simple + test-runner? + ;; Running specific tests with a specified runner + test-apply + test-with-runner + ;; Result kind + test-passed? + test-result-kind + ;; Test result properties + test-result-alist + test-result-clear + test-result-ref + test-result-remove + test-result-set! + ;; Call-back hooks + test-runner-on-bad-count + test-runner-on-bad-count! + test-runner-on-bad-end-name + test-runner-on-bad-end-name! + test-runner-on-final + test-runner-on-final! + test-runner-on-group-begin + test-runner-on-group-begin! + test-runner-on-group-end + test-runner-on-group-end! + test-runner-on-test-begin + test-runner-on-test-begin! + test-runner-on-test-end + test-runner-on-test-end! + ;; Simple runner call-back functions + test-on-bad-count-simple + test-on-bad-end-name-simple + test-on-group-begin-simple + test-on-group-end-simple + test-on-test-begin-simple + test-on-test-end-simple + ;; Test-runner components + test-runner-aux-value + test-runner-aux-value! + test-runner-fail-count + test-runner-group-path + test-runner-group-stack + test-runner-pass-count + test-runner-reset + test-runner-skip-count + test-runner-test-name + test-runner-xfail-count + test-runner-xpass-count + + ;; Additional functionality not in SRFI-64: + define-test + test-procedure? + test-thunk + + &bad-end-name + bad-end-name? + bad-end-name-begin-name + bad-end-name-end-name)) + +(define (set-documentation! symbol docstring) + "Set the docstring for @var{symbol} in current module to @var{docstring}. + +Do not use this procedure for forms that already support setting the +docstring. Should directly follow the definition of @var{symbol}. + +Example: + +@lisp +(define answer 42) +(set-documentation! 'answer + \"The answer to life, the universe, and everything.\") +@end lisp" + (set-object-property! (module-ref (current-module) symbol) + 'documentation + docstring)) (cond-expand-provide (current-module) '(srfi-64)) -(include-from-path "srfi/srfi-64/testing.scm") +(define-record-type + (%make-test-runner) + test-runner? + ;; Test result properties + (result-alist test-runner-result-alist test-runner-result-alist!) + ;; Call-back hooks + (on-bad-count test-runner-on-bad-count test-runner-on-bad-count!) + (on-bad-end-name test-runner-on-bad-end-name test-runner-on-bad-end-name!) + (on-final test-runner-on-final test-runner-on-final!) + (on-group-begin test-runner-on-group-begin test-runner-on-group-begin!) + (on-group-end test-runner-on-group-end test-runner-on-group-end!) + (on-test-begin test-runner-on-test-begin test-runner-on-test-begin!) + (on-test-end test-runner-on-test-end test-runner-on-test-end!) + ;; Test-runner components + (counts test-runner-counts test-runner-counts!) + + (test-name test-runner-test-name test-runner-test-name!) + + (group-stack test-runner-group-stack test-runner-group-stack!) + + (aux-value test-runner-aux-value test-runner-aux-value!) + + ;; Implementation details + (fail-list test-runner-fail-list test-runner-fail-list!) + (groups test-runner-groups test-runner-groups!) + (run-list test-runner-run-list test-runner-run-list!) + (skip-list test-runner-skip-list test-runner-skip-list!)) + +(define (test-runner-reset runner) + (test-runner-result-alist! runner '()) + + (test-runner-counts! runner '()) + + (test-runner-test-name! runner #f) + + (test-runner-group-stack! runner '()) + + (test-runner-fail-list! runner '()) + (test-runner-groups! runner '()) + ;; run-list is not documented as part of the test-runner, so it should *not* + ;; be cleared. + (test-runner-skip-list! runner '())) + +(define (test-runner-group-path runner) + "Return list of names of groups we're nested in, with the outermost group +first." + (reverse (test-runner-group-stack runner))) + +(define (test-runner-fail-count r) + "Return the number of tests that failed, but were expected to pass." + (or (assq-ref (test-runner-counts r) 'fail) 0)) + +(define (test-runner-pass-count r) + "Return the number of tests that passed, and were expected to pass." + (or (assq-ref (test-runner-counts r) 'pass) 0)) + +(define (test-runner-skip-count r) + "Return the number of tests or test groups that were skipped." + (or (assq-ref (test-runner-counts r) 'skip) 0)) + +(define (test-runner-xfail-count r) + "Return the number of tests that failed, and were expected to fail." + (or (assq-ref (test-runner-counts r) 'xfail) 0)) + +(define (test-runner-xpass-count r) + "Return the number of tests that passed, but were expected to fail." + (or (assq-ref (test-runner-counts r) 'xpass) 0)) + + +;;; +;;; Test specifiers +;;; +(define (test-match-name name) + "Return a specifier matching the current test name against @var{name}." + (λ (runner) + (equal? name (test-runner-test-name runner)))) + +(define* (test-match-nth n #:optional (count 1)) + "Return a stateful predicate. A counter keeps track of how many times it +has been called. The predicate matches the @var{n}'th time it is +called (where 1 is the first time), and the next @code{(- @var{count} 1)} +times, where @var{count} defaults to 1." + (let ((i 0) + (m (+ n count -1))) + (λ (runner) + (set! i (1+ i)) + (and (>= i n) (<= i m))))) + +(define (obj->specifier obj) + "Convert an object to a specifier accounting for the convenience +short-hands." + (match obj + ((? procedure? spec) + spec) + ((? string? name) + (test-match-name name)) + ((? integer? count) + (test-match-nth 1 count)))) + +(define (test-match-any . specifiers) + "Return specifier matching if any specifier in @var{specifiers} matches. +Each specifier is applied, in order, so side-effects from a later specifier +happen even if an earlier specifier is true." + (let ((specifiers (map obj->specifier specifiers))) + (λ (runner) + (fold (λ (specifier seed) + (or (specifier runner) seed)) + #f + specifiers)))) + +(define (test-match-all . specifiers) + "Return specifier matching if all @var{specifiers} match. Each specifier is +applied, in order, so side-effects from a later specifier happen even if an +earlier specifier is true." + (let ((specifiers (map obj->specifier specifiers))) + (λ (runner) + (fold (λ (specifier seed) + (and (specifier runner) seed)) + #t + specifiers)))) + + +;;; +;;; Skipping selected tests +;;; +(define (test-skip specifier) + "Evaluating test-skip adds the resulting specifier to the set of currently +active skip-specifiers. Before each test (or test-group) the set of active +skip-specifiers are applied to the active test-runner. If any specifier +matches, then the test is skipped. + +@var{specifier} can be a predicate of one argument (the test runner), a +string (used as if @code{(test-match-name @var{specifier})}) or an +integer (used as if @code{(test-match-nth 1 @var{specifier})})." + (let ((r (test-runner-current))) + (test-runner-skip-list! r (cons (obj->specifier specifier) + (test-runner-skip-list r))))) + +(define (any-specifier-matches? specifiers) + "Does any specifier in @var{specifiers} match current test? + +All specifiers are always evaluated." + (let ((r (test-runner-current))) + (fold (λ (specifier seed) + (or (specifier r) seed)) + #f + specifiers))) + +(define (should-skip?) + "Should current test be skipped?" + (any-specifier-matches? (test-runner-skip-list (test-runner-current)))) + + +;;; +;;; Expected failures +;;; +(define (test-expect-fail specifier) + "Matching tests (where matching is defined as in test-skip) are expected to +fail. This only affects test reporting, not test execution." + (let ((r (test-runner-current))) + (test-runner-fail-list! r (cons (obj->specifier specifier) + (test-runner-fail-list r))))) + +(define (should-fail?) + "Should the current test fail?" + (any-specifier-matches? (test-runner-fail-list (test-runner-current)))) + + +;;; +;;; Test result properties +;;; +(define* (test-result-ref runner pname #:optional default) + "Returns the property value associated with the @var{pname} property name. +If there is no value associated with @var{pname} return @var{default}, or +@code{#f} if @var{default} is not specified." + (or (assoc-ref (test-runner-result-alist runner) pname) + default)) + +(define (test-result-set! runner pname value) + "Sets the property value associated with the @var{pname} property name to +@var{value}." + (test-runner-result-alist! runner + (assoc-set! (test-runner-result-alist runner) + pname + value))) + +(define (test-result-remove runner pname) + "Remove the property with the name @var{pname}." + (test-runner-result-alist! runner + (assoc-remove! (test-runner-result-alist runner) + pname))) + +(define (test-result-clear runner) + "Remove all result properties." + ;; Standard says the following for test-result-alist: + ;; > However, a test-result-clear does not modify the returned alist. + ;; + ;; Therefore we assign a new empty list instead of removing all entries. + (test-runner-result-alist! runner '())) + +(define test-result-alist test-runner-result-alist) +(set-documentation! 'test-result-alist + "Returns an association list of the current result properties. It is +unspecified if the result shares state with the test-runner. The result +should not be modified; on the other hand, the result may be implicitly +modified by future @code{test-result-set!} or @code{test-result-remove} calls. +However, a @code{test-result-clear} does not modify the returned alist.") + + +;;; +;;; Result kind +;;; +(define* (test-result-kind #:optional (runner (test-runner-current))) + "Result code of most recent test. Returns @code{#f} if no tests have been run yet. +If we have started on a new test, but do not have a result yet, then the +result kind is @code{'xfail} if the test is expected to fail, @code{'skip} if +the test is supposed to be skipped, or @code{#f} otherwise." + (test-result-ref runner 'result-kind)) + +(define* (test-passed? #:optional (runner (test-runner-current))) + "Is the value of @code{(test-result-kind [runner])} one of @code{'pass} or +@code{'xpass}? + +This function is of little use, since @code{'xpass} is type of failure. You +should write your own wrapper checking @code{'pass} and @code{'xfail} +instead." + (let ((result (test-result-kind runner))) + (or (eq? result 'pass) + (eq? result 'xpass)))) + + +;;; +;;; Simple test runner +;;; +(define (test-on-bad-count-simple runner actual-count expected-count) + "Log the discrepancy between expected and actual test counts." + (format #t "*** Expected to run ~a tests, but ~a was executed. ***~%" + expected-count actual-count)) + +(define (test-on-bad-end-name-simple runner begin-name end-name) + "Log the discrepancy between the -begin and -end suite names." + (format #t "*** Suite name mismatch: test-begin (~a) != test-end (~a) ***~%" + begin-name end-name)) + +(define (test-on-final-simple runner) + "Display summary of the test suite." + (display "*** Test suite finished. ***\n") + (for-each (λ (x) + (let ((count ((cdr x) runner))) + (when (> count 0) + (format #t "*** # of ~a: ~a~%" (car x) count)))) + `(("expected passes " . ,test-runner-pass-count) + ("expected failures " . ,test-runner-xfail-count) + ("unexpected passes " . ,test-runner-xpass-count) + ("unexpected failures" . ,test-runner-fail-count) + ("skips " . ,test-runner-skip-count)))) + +(define (test-on-group-begin-simple runner suite-name count) + "Log that the group is beginning." + (format #t "*** Entering test group: ~a~@[ (# of tests: ~a) ~] ***~%" + suite-name count)) + +(define (test-on-group-end-simple runner) + "Log that the group is ending." + ;; There is no portable way to get the test group name. + (format #t "*** Leaving test group: ~a ***~%" + (car (test-runner-group-stack runner)))) + +(define (test-on-test-begin-simple runner) + "Do nothing." + #f) + +(define (test-on-test-end-simple runner) + "Log that test is done." + (define (maybe-print-prop prop pretty?) + (let* ((val (test-result-ref runner prop)) + (val (string-trim-both + (with-output-to-string + (λ () + (if pretty? + (pretty-print val #:per-line-prefix " ") + (display val))))))) + (when val + (format #t "~a: ~a~%" prop val)))) + + (let ((result-kind (test-result-kind runner))) + ;; Skip tests not executed due to run list. + (when result-kind + (format #t "* ~:@(~a~): ~a~%" + result-kind + (test-runner-test-name runner)) + (unless (member result-kind '(pass xfail)) + (maybe-print-prop 'source-file #f) + (maybe-print-prop 'source-line #f) + (maybe-print-prop 'source-form #t) + (maybe-print-prop 'expected-value #f) + (maybe-print-prop 'expected-error #t) + (maybe-print-prop 'actual-value #f) + (maybe-print-prop 'actual-error #t))))) + +(define (test-runner-simple) + "Creates a new simple test-runner, that prints errors and a summary on the +standard output port." + (let ((r (%make-test-runner))) + (test-runner-reset r) + + (test-runner-on-bad-count! r test-on-bad-count-simple) + (test-runner-on-bad-end-name! r test-on-bad-end-name-simple) + (test-runner-on-final! r test-on-final-simple) + (test-runner-on-group-begin! r test-on-group-begin-simple) + (test-runner-on-group-end! r test-on-group-end-simple) + (test-runner-on-test-begin! r test-on-test-begin-simple) + (test-runner-on-test-end! r test-on-test-end-simple) + + (test-runner-run-list! r (make-parameter #f)) + r)) + + +;;; +;;; Test runner +;;; + +(define test-runner-current (make-parameter #f)) +(set-documentation! 'test-runner-current + "Parameter representing currently installed test runner.") + +(define (test-runner-get) + "Get current test runner if any, raise an exception otherwise." + (or (test-runner-current) + (throw 'no-test-runner))) + +(define test-runner-factory (make-parameter test-runner-simple)) +(set-documentation! 'test-runner-factory + "Factory producing new test runner. Has to be a procedure of arity 0 +returning new test runner. Defaults to @code{test-runner-simple}.") + +(define (test-runner-create) + "Create a new test-runner. Equivalent to @code{((test-runner-factory))}." + ((test-runner-factory))) + +(define (test-runner-null) + (let ((r (%make-test-runner)) + (dummy-1 (λ (_) #f)) + (dummy-3 (λ (_ __ ___) #f))) + (test-runner-reset r) + + (test-runner-on-bad-count! r dummy-3) + (test-runner-on-bad-end-name! r dummy-3) + (test-runner-on-final! r dummy-1) + (test-runner-on-group-begin! r dummy-3) + (test-runner-on-group-end! r dummy-1) + (test-runner-on-test-begin! r dummy-1) + (test-runner-on-test-end! r dummy-1) + + (test-runner-run-list! r (make-parameter #f)) + r)) + + +;;; +;;; Test groups and paths +;;; +(define-record-type + (make-group name count executed-count installed-runner? previous-skip-list) + group? + (name group-name) + (count group-count) + (executed-count group-executed-count group-executed-count!) + (installed-runner? group-installed-runner?) + (previous-skip-list group-previous-skip-list)) + +(define (increment-executed-count r) + "Increment executed count of the first group." + (let ((groups (test-runner-groups r))) + (unless (null? groups) + (let ((group (car groups))) + (group-executed-count! group + (1+ (group-executed-count group))))))) + +(define* (test-begin suite-name #:optional count) + "Enter a new test group." + (let* ((r (test-runner-current)) + (r install? (if r + (values r #f) + (values (test-runner-create) #t))) + (group (make-group suite-name + count + 0 + install? + (test-runner-skip-list r)))) + (when install? + (test-runner-current r)) + + (test-runner-test-name! r suite-name) + (test-runner-groups! r (cons group (test-runner-groups r))) + ;; Per-strict reading of SRFI-64, -group-stack is required to be + ;; non-copying, hence non-computed. So duplicate the information already + ;; present in -groups here. + (test-runner-group-stack! r (cons suite-name (test-runner-group-stack r))) + + ((test-runner-on-group-begin r) r suite-name count))) + +(define* (test-end #:optional suite-name) + "Leave the current test group." + (let* ((r (test-runner-current)) + (group (car (test-runner-groups r)))) + + (let ((begin-name (car (test-runner-group-stack r))) + (end-name suite-name)) + (when (and end-name (not (string=? begin-name end-name))) + ((test-runner-on-bad-end-name r) r begin-name end-name) + (raise-exception (make-bad-end-name begin-name end-name)))) + + (let ((expected-count (group-count group)) + (actual-count (group-executed-count group))) + (when (and expected-count (not (= expected-count actual-count))) + ((test-runner-on-bad-count r) r actual-count expected-count))) + + ((test-runner-on-group-end r) r) + + (test-runner-groups! r (cdr (test-runner-groups r))) + (test-runner-group-stack! r (cdr (test-runner-group-stack r))) + (test-runner-skip-list! r (group-previous-skip-list group)) + + (if (null? (test-runner-group-stack r)) + ((test-runner-on-final r) r) + (increment-executed-count r)) + + (when (group-installed-runner? group) + (test-runner-current #f)))) + +(define-syntax test-group + (syntax-rules () + "Execute @var{decl-or-expr ...} in a named test group. The whole group is +skipped if it matches an active test-skip." + ((_ suite-name decl-or-expr ...) + (let ((r (test-runner-current)) + (name suite-name)) + ;; Since test-runner stores skip state, if we do not have test-runner, + ;; the test cannot be on skip list (it does not exist). + (when (or (not r) + (begin + ;; Specifiers are using -test-name, so we need to do this + ;; here and not rely on test-begin. + (test-runner-test-name! r name) + (not (should-skip?)))) + (dynamic-wind + (λ () (test-begin name)) + (λ () decl-or-expr ...) + (λ () (test-end name)))))))) + + +;;; +;;; Handling set-up and cleanup +;;; +(define-syntax test-group-with-cleanup + (syntax-rules () + "Execute each of the @var{decl-or-expr} forms in order, and then execute +the @var{cleanup-form}. The latter shall be executed even if one of a +@var{decl-or-expr} forms raises an exception." + ((_ suite-name decl-or-expr ... cleanup-form) + (dynamic-wind + (λ () #t) + (λ () (test-group suite-name decl-or-expr ...)) + (λ () cleanup-form))))) + + +;;; +;;; Simple test-cases +;;; +(define (syntax->source-properties form) + "Extract properties of syntax @var{form} and return them as a alist with +keys compatible with Guile's SRFI-64 implementation." + (let* ((source (syntax-source form)) + (file (and=> source (cut assq-ref <> 'filename))) + (line (and=> source (cut assq-ref <> 'line))) + ;; I do not care about column. Tests are not nested enough. + (file-alist (if file + `((source-file . ,file)) + '())) + (line-alist (if line + `((source-line . ,(1+ line))) ; 1st line should be 1. + '()))) + (datum->syntax form + `((source-form . ,(syntax->datum form)) + ,@file-alist + ,@line-alist)))) + +(define (preliminary-result-kind! r fail? skip?) + "Set result-kind before the test was run based on @var{fail?} and +@var{skip?}." + (test-result-set! r 'result-kind (cond + ;; I think this order is stupid, but it is + ;; what SRFI demands. + (fail? 'xfail) + (skip? 'skip) + (else #f)))) + +(define (final-result-kind! r match? fail-expected?) + "Set the final result-kind based on @var{match?} and @var{fail-expected?}." + (test-result-set! r 'result-kind (cond ((and match? fail-expected?) + 'xpass) + (match? + 'pass) + (fail-expected? + 'xfail) + (else + 'fail)))) + +(define (fail-on-exception thunk) + "Run the thunk and return the result. If exception occurs, record it and +return @code{#f}." + (with-exception-handler + (λ (exc) + (test-result-set! (test-runner-current) 'actual-error exc) + #f) + (λ () (thunk)) + #:unwind? #t)) + +(define (increment-test-count r) + "Increment the test count for the current 'result-kind." + (let* ((kind (test-result-kind r)) + (counts (test-runner-counts r)) + (c (or (assq-ref counts kind) 0))) + (test-runner-counts! r (assq-set! counts kind (1+ c))))) + +(define (test-thunk test-name properties thunk) + "Run test @var{thunk} while taking into account currently active skip list +and such. The result alist is initially set to @var{properties}, however +@var{thunk} is expected to make additions (actual, expected values, ...). + +@var{thunk} must return @code{#f} to indicate test failure. Otherwise the +test is considered successful." + (let ((r (test-runner-current))) + ;; Since skip checks are using -test-name, set it first. + (test-runner-test-name! r (or test-name "")) + (test-runner-result-alist! r properties) + + (let ((fail? (should-fail?)) + (run? (should-run?)) + (skip? (should-skip?))) + (preliminary-result-kind! r fail? skip?) + ((test-runner-on-test-begin r) r) + (when run? + (if skip? + (test-result-set! r 'result-kind 'skip) + (begin + (final-result-kind! r (fail-on-exception thunk) fail?) + (increment-executed-count r)))) + ((test-runner-on-test-end r) r) + (increment-test-count r)))) + +(define-syntax %test-assert + (λ (x) + (syntax-case x () + ((_ syn test-name expression) + #`(test-thunk (let () test-name) + '#,(syntax->source-properties #'syn) + (λ () + (let ((r (test-runner-current)) + (a (let () expression))) + (test-result-set! r 'actual-value a) + a))))))) + +(define-syntax test-assert + (λ (x) + (syntax-case x () + ((_ test-name expression) + #`(%test-assert #,x test-name expression)) + ((_ expression) + #`(%test-assert #,x #f expression))))) +(set-documentation! 'test-assert + "@defspec test-assert test-name expression +@defspecx test-assert expression +Evaluate the @var{expression}, the test passes if the result is true. + +@var{test-name} and @var{expression} are evaluated just once. It is an error +to invoke @code{test-assert} if there is no current test runner. + +@end defspec") + +(define-syntax %%test-2 + (λ (x) + (syntax-case x () + ((_ syn test-proc test-name expected test-expr) + #`(test-thunk (let () test-name) + '#,(syntax->source-properties #'syn) + (λ () + (let ((r (test-runner-current)) + (e (let () expected)) + (a (let () test-expr))) + (test-result-set! r 'expected-value e) + (test-result-set! r 'actual-value a) + (test-proc e a)))))))) + +(define-syntax %test-2 + (syntax-rules () + ((_ name test-proc) + (define-syntax name + (λ (x) + (syntax-case x () + ((_ test-name expected test-expr) + #`(%%test-2 #,x test-proc test-name expected test-expr)) + ((_ expected test-expr) + #`(%%test-2 #,x test-proc #f expected test-expr)))))))) + +(%test-2 test-eq eq?) +(%test-2 test-eqv eqv?) +(%test-2 test-equal equal?) + +(set-documentation! 'test-eq + "@defspec test-eq test-name expected test-expr +@defspecx test-eq expected test-expr +Test whether result of @var{test-expr} matches @var{expected} using +@code{eq?}. + +@end defspec") +(set-documentation! 'test-eqv + "@defspec test-eqv test-name expected test-expr +@defspecx test-eqv expected test-expr +Test whether result of @var{test-expr} matches @var{expected} using +@code{eqv?}. + +@end defspec") +(set-documentation! 'test-equal + "@defspec test-equal test-name expected test-expr +@defspecx test-equal expected test-expr +Test whether result of @var{test-expr} matches @var{expected} using +@code{equal?}. + +@end defspec") + +(define (within-epsilon ε) + (λ (expected actual) + (and (>= actual (- expected ε)) + (<= actual (+ expected ε))))) + +(define-syntax %test-approximate + (λ (x) + (syntax-case x () + ((_ syn test-name expected test-expr error) + #`(test-thunk (let () test-name) + '#,(syntax->source-properties #'syn) + (λ () + (let ((r (test-runner-current)) + (e (let () expected)) + (a (let () test-expr)) + (ε (let () error))) + (test-result-set! r 'expected-value e) + (test-result-set! r 'actual-value a) + (test-result-set! r 'epsilon ε) + ((within-epsilon ε) e a)))))))) + +(define-syntax test-approximate + (λ (x) + (syntax-case x () + ((_ test-name expected test-expr error) + #`(%test-approximate #,x test-name expected test-expr error)) + ((_ expected test-expr error) + #`(%test-approximate #,x #f expected test-expr error))))) +(set-documentation! 'test-approximate + "@defspec test-approximate test-name expected test-expr error +@defspecx test-approximate expected test-expr error +Test whether result of @var{test-expr} is within @var{error} of +@var{expected}. + +@end defspec") + +(define-syntax %test-error + (λ (x) + (syntax-case x () + ((_ syn test-name error-type test-expr) + #`(test-thunk (let () test-name) + '#,(syntax->source-properties #'syn) + (λ () + (let ((r (test-runner-current)) + (e-type (let () error-type))) + (test-result-set! r 'expected-error e-type) + (with-exception-handler + (λ (exc) + (test-result-set! r 'actual-error exc) + (match e-type + (#t #t) + (#f #f) + ((? symbol? sym) + (eq? sym (exception-kind exc))) + ((? procedure? proc) + (proc exc)) + ((? exception-type? exc-type) + ((exception-predicate exc-type) exc)))) + (λ () + test-expr + (not e-type)) + #:unwind? #t)))))))) + +(define-syntax test-error + (λ (x) + (syntax-case x () + ((_ test-name error-type test-expr) + #`(%test-error #,x test-name error-type test-expr)) + ((_ error-type test-expr) + #`(%test-error #,x #f error-type test-expr)) + ((_ test-expr) + #`(%test-error #,x #f #t test-expr))))) +(set-documentation! 'test-error + "@defspec test-error test-name error-type test-expr +@defspecx test-error error-type test-expr +@defspecx test-error test-expr +Evaluating @var{test-expr} is expected to signal an error. The kind of error +is indicated by @var{error-type}. It is always evaluated (even when no +exception is raised) and can be one of the following. + +@table @code +@item #t +Per specification, this matches any exception. + +@item #f +Pass if no exception is raised. + +@item symbol? +Symbols can be used to match against exceptions created using +@code{throw} and @code{error}. + +@item procedure? +The exception object is passed to the predicate procedure. Example +would be @code{external-error?}. + +@item exception-type? +Exception type like for example @code{&external-error}. + +@end table + +@end defspec") + + +;;; +;;; Testing syntax +;;; +(define (test-read-eval-string string) + "Parse the @var{string} (using @code{read}), evaluate and return the +result. + +An error is signaled if there are unread characters after the @code{read} is +done." + (with-input-from-string string + (λ () + (let ((exp (read))) + (unless (eof-object? (read-char)) + (error "read did not consume whole string")) + (eval exp (current-module)))))) + + +;;; +;;; Running specific tests with a specified runner +;;; +(define-syntax test-with-runner + (syntax-rules () + "Execute each @var{decl-or-expr} in order in a context where the current +test-runner is @var{runner}." + ((_ runner decl-or-expr ...) + (parameterize ((test-runner-current runner)) + #t + decl-or-expr ...)))) + +(define (should-run?) + "Should current test be considered for execution according to currently +active run list?" + (let ((run-list ((test-runner-run-list (test-runner-current))))) + (if run-list + (any-specifier-matches? run-list) + #t))) + +(define test-apply + (match-lambda* + (((? test-runner? r) specifiers ... thunk) + (test-with-runner r + (parameterize (((test-runner-run-list r) + (if (null? specifiers) + #f + (map obj->specifier specifiers)))) + (thunk)))) + ((specifiers ... thunk) + (apply test-apply + (or (test-runner-current) + (test-runner-create)) + `(,@specifiers ,thunk))))) +(set-documentation! 'test-apply + "@defunx test-apply runner specifier ... procedure +@defunx test-apply specifier ... procedure + +Call @var{procedure} with no arguments using the specified @var{runner} as the +current test-runner. If runner is omitted, then @code{(test-runner-current)} +is used. If there is no current runner, one is created as in +@code{test-begin}. If one or more @var{specifiers} are listed then only tests +matching the @var{specifiers} are executed. A specifier has the same form as +one used for @code{test-skip}. A test is executed if it matches any of the +specifiers in the @code{test-apply} and does not match any active +@code{test-skip} specifiers.") + + +;;; +;;; Additional functionality not covered by the SRFI. +;;; + +(define %define-test-property 'srfi-64-extra/proc-for-test) + +(define-syntax define-test + (λ (x) + (syntax-case x () + ((_ name e ...) + (let* ((binding-syn + (datum->syntax x + (string->symbol + (string-append "test-procedure-" + (syntax->datum #'name)))))) + #`(begin + (define (#,binding-syn) + (test-begin name) + e ... + (test-end name)) + (set-procedure-property! #,binding-syn + %define-test-property #t))))))) +(set-documentation! 'define-test + "@defspec define-test name form ... +Introduce a top-level procedure (using @code{define}) with body equivalent to + +@lisp +(test-begin @var{name}) +@var{form ...} +(test-end @var{name}) +@end lisp + +Due to the procedure name being derived from @var{name}, the @var{name} should +be unique per-module. + +The procedure has @code{%define-test-property} procedure property set to +@code{#t}. This can be used by test driver to discover all test procedures in +the module. + +@end defspec") + +(define (test-procedure? obj) + "Return whether @var{obj} is a procedure defined by define-test." + (and (procedure? obj) + (procedure-property obj %define-test-property))) + +(define-exception-type &bad-end-name &programming-error + make-bad-end-name bad-end-name? + (begin-name bad-end-name-begin-name) + (end-name bad-end-name-end-name)) +(set-documentation! '&bad-end-name + "Exception type raised when @var{suite-name} in @code{test-end} differs from +matching @code{test-begin}.") diff --git a/module/srfi/srfi-64/testing.scm b/module/srfi/srfi-64/testing.scm deleted file mode 100644 index cdaab140f..000000000 --- a/module/srfi/srfi-64/testing.scm +++ /dev/null @@ -1,1044 +0,0 @@ -;; Copyright (c) 2005, 2006, 2007, 2012, 2013 Per Bothner -;; Added "full" support for Chicken, Gauche, Guile and SISC. -;; Alex Shinn, Copyright (c) 2005. -;; Modified for Scheme Spheres by Álvaro Castro-Castilla, Copyright (c) 2012. -;; Support for Guile 2 by Mark H Weaver , Copyright (c) 2014. -;; -;; Permission is hereby granted, free of charge, to any person -;; obtaining a copy of this software and associated documentation -;; files (the "Software"), to deal in the Software without -;; restriction, including without limitation the rights to use, copy, -;; modify, merge, publish, distribute, sublicense, and/or sell copies -;; of the Software, and to permit persons to whom the Software is -;; furnished to do so, subject to the following conditions: -;; -;; The above copyright notice and this permission notice shall be -;; included in all copies or substantial portions of the Software. -;; -;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, -;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF -;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND -;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS -;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN -;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN -;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE -;; SOFTWARE. - -(cond-expand - (chicken - (require-extension syntax-case)) - (guile-2 - (use-modules (srfi srfi-9) - ;; In 2.0.9, srfi-34 and srfi-35 are not well integrated - ;; with either Guile's native exceptions or R6RS exceptions. - ;;(srfi srfi-34) (srfi srfi-35) - (srfi srfi-39))) - (guile - (use-modules (ice-9 syncase) (srfi srfi-9) - ;;(srfi srfi-34) (srfi srfi-35) - not in Guile 1.6.7 - (srfi srfi-39))) - (sisc - (require-extension (srfi 9 34 35 39))) - (kawa - (module-compile-options warn-undefined-variable: #t - warn-invoke-unknown-method: #t) - (provide 'srfi-64) - (provide 'testing) - (require 'srfi-34) - (require 'srfi-35)) - (else () - )) - -(cond-expand - (kawa - (define-syntax %test-export - (syntax-rules () - ((%test-export test-begin . other-names) - (module-export %test-begin . other-names))))) - (else - (define-syntax %test-export - (syntax-rules () - ((%test-export . names) (if #f #f)))))) - -;; List of exported names -(%test-export - test-begin ;; must be listed first, since in Kawa (at least) it is "magic". - test-end test-assert test-eqv test-eq test-equal - test-approximate test-assert test-error test-apply test-with-runner - test-match-nth test-match-all test-match-any test-match-name - test-skip test-expect-fail test-read-eval-string - test-runner-group-path test-group test-group-with-cleanup - test-result-ref test-result-set! test-result-clear test-result-remove - test-result-kind test-passed? - test-log-to-file - ; Misc test-runner functions - test-runner? test-runner-reset test-runner-null - test-runner-simple test-runner-current test-runner-factory test-runner-get - test-runner-create test-runner-test-name - ;; test-runner field setter and getter functions - see %test-record-define: - test-runner-pass-count test-runner-pass-count! - test-runner-fail-count test-runner-fail-count! - test-runner-xpass-count test-runner-xpass-count! - test-runner-xfail-count test-runner-xfail-count! - test-runner-skip-count test-runner-skip-count! - test-runner-group-stack test-runner-group-stack! - test-runner-on-test-begin test-runner-on-test-begin! - test-runner-on-test-end test-runner-on-test-end! - test-runner-on-group-begin test-runner-on-group-begin! - test-runner-on-group-end test-runner-on-group-end! - test-runner-on-final test-runner-on-final! - test-runner-on-bad-count test-runner-on-bad-count! - test-runner-on-bad-end-name test-runner-on-bad-end-name! - test-result-alist test-result-alist! - test-runner-aux-value test-runner-aux-value! - ;; default/simple call-back functions, used in default test-runner, - ;; but can be called to construct more complex ones. - test-on-group-begin-simple test-on-group-end-simple - test-on-bad-count-simple test-on-bad-end-name-simple - test-on-final-simple test-on-test-end-simple - test-on-final-simple) - -(cond-expand - (srfi-9 - (define-syntax %test-record-define - (syntax-rules () - ((%test-record-define alloc runner? (name index setter getter) ...) - (define-record-type test-runner - (alloc) - runner? - (name setter getter) ...))))) - (else - (define %test-runner-cookie (list "test-runner")) - (define-syntax %test-record-define - (syntax-rules () - ((%test-record-define alloc runner? (name index getter setter) ...) - (begin - (define (runner? obj) - (and (vector? obj) - (> (vector-length obj) 1) - (eq (vector-ref obj 0) %test-runner-cookie))) - (define (alloc) - (let ((runner (make-vector 23))) - (vector-set! runner 0 %test-runner-cookie) - runner)) - (begin - (define (getter runner) - (vector-ref runner index)) ...) - (begin - (define (setter runner value) - (vector-set! runner index value)) ...))))))) - -(%test-record-define - %test-runner-alloc test-runner? - ;; Cumulate count of all tests that have passed and were expected to. - (pass-count 1 test-runner-pass-count test-runner-pass-count!) - (fail-count 2 test-runner-fail-count test-runner-fail-count!) - (xpass-count 3 test-runner-xpass-count test-runner-xpass-count!) - (xfail-count 4 test-runner-xfail-count test-runner-xfail-count!) - (skip-count 5 test-runner-skip-count test-runner-skip-count!) - (skip-list 6 %test-runner-skip-list %test-runner-skip-list!) - (fail-list 7 %test-runner-fail-list %test-runner-fail-list!) - ;; Normally #t, except when in a test-apply. - (run-list 8 %test-runner-run-list %test-runner-run-list!) - (skip-save 9 %test-runner-skip-save %test-runner-skip-save!) - (fail-save 10 %test-runner-fail-save %test-runner-fail-save!) - (group-stack 11 test-runner-group-stack test-runner-group-stack!) - (on-test-begin 12 test-runner-on-test-begin test-runner-on-test-begin!) - (on-test-end 13 test-runner-on-test-end test-runner-on-test-end!) - ;; Call-back when entering a group. Takes (runner suite-name count). - (on-group-begin 14 test-runner-on-group-begin test-runner-on-group-begin!) - ;; Call-back when leaving a group. - (on-group-end 15 test-runner-on-group-end test-runner-on-group-end!) - ;; Call-back when leaving the outermost group. - (on-final 16 test-runner-on-final test-runner-on-final!) - ;; Call-back when expected number of tests was wrong. - (on-bad-count 17 test-runner-on-bad-count test-runner-on-bad-count!) - ;; Call-back when name in test=end doesn't match test-begin. - (on-bad-end-name 18 test-runner-on-bad-end-name test-runner-on-bad-end-name!) - ;; Cumulate count of all tests that have been done. - (total-count 19 %test-runner-total-count %test-runner-total-count!) - ;; Stack (list) of (count-at-start . expected-count): - (count-list 20 %test-runner-count-list %test-runner-count-list!) - (result-alist 21 test-result-alist test-result-alist!) - ;; Field can be used by test-runner for any purpose. - ;; test-runner-simple uses it for a log file. - (aux-value 22 test-runner-aux-value test-runner-aux-value!) -) - -(define (test-runner-reset runner) - (test-result-alist! runner '()) - (test-runner-pass-count! runner 0) - (test-runner-fail-count! runner 0) - (test-runner-xpass-count! runner 0) - (test-runner-xfail-count! runner 0) - (test-runner-skip-count! runner 0) - (%test-runner-total-count! runner 0) - (%test-runner-count-list! runner '()) - (%test-runner-run-list! runner #t) - (%test-runner-skip-list! runner '()) - (%test-runner-fail-list! runner '()) - (%test-runner-skip-save! runner '()) - (%test-runner-fail-save! runner '()) - (test-runner-group-stack! runner '())) - -(define (test-runner-group-path runner) - (reverse (test-runner-group-stack runner))) - -(define (%test-null-callback runner) #f) - -(define (test-runner-null) - (let ((runner (%test-runner-alloc))) - (test-runner-reset runner) - (test-runner-on-group-begin! runner (lambda (runner name count) #f)) - (test-runner-on-group-end! runner %test-null-callback) - (test-runner-on-final! runner %test-null-callback) - (test-runner-on-test-begin! runner %test-null-callback) - (test-runner-on-test-end! runner %test-null-callback) - (test-runner-on-bad-count! runner (lambda (runner count expected) #f)) - (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f)) - runner)) - -;; Not part of the specification. FIXME -;; Controls whether a log file is generated. -(define test-log-to-file #t) - -(define (test-runner-simple) - (let ((runner (%test-runner-alloc))) - (test-runner-reset runner) - (test-runner-on-group-begin! runner test-on-group-begin-simple) - (test-runner-on-group-end! runner test-on-group-end-simple) - (test-runner-on-final! runner test-on-final-simple) - (test-runner-on-test-begin! runner test-on-test-begin-simple) - (test-runner-on-test-end! runner test-on-test-end-simple) - (test-runner-on-bad-count! runner test-on-bad-count-simple) - (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple) - runner)) - -(cond-expand - (srfi-39 - (define test-runner-current (make-parameter #f)) - (define test-runner-factory (make-parameter test-runner-simple))) - (else - (define %test-runner-current #f) - (define-syntax test-runner-current - (syntax-rules () - ((test-runner-current) - %test-runner-current) - ((test-runner-current runner) - (set! %test-runner-current runner)))) - (define %test-runner-factory test-runner-simple) - (define-syntax test-runner-factory - (syntax-rules () - ((test-runner-factory) - %test-runner-factory) - ((test-runner-factory runner) - (set! %test-runner-factory runner)))))) - -;; A safer wrapper to test-runner-current. -(define (test-runner-get) - (let ((r (test-runner-current))) - (if (not r) - (cond-expand - (srfi-23 (error "test-runner not initialized - test-begin missing?")) - (else #t))) - r)) - -(define (%test-specifier-matches spec runner) - (spec runner)) - -(define (test-runner-create) - ((test-runner-factory))) - -(define (%test-any-specifier-matches list runner) - (let ((result #f)) - (let loop ((l list)) - (cond ((null? l) result) - (else - (if (%test-specifier-matches (car l) runner) - (set! result #t)) - (loop (cdr l))))))) - -;; Returns #f, #t, or 'xfail. -(define (%test-should-execute runner) - (let ((run (%test-runner-run-list runner))) - (cond ((or - (not (or (eqv? run #t) - (%test-any-specifier-matches run runner))) - (%test-any-specifier-matches - (%test-runner-skip-list runner) - runner)) - (test-result-set! runner 'result-kind 'skip) - #f) - ((%test-any-specifier-matches - (%test-runner-fail-list runner) - runner) - (test-result-set! runner 'result-kind 'xfail) - 'xfail) - (else #t)))) - -(define (%test-begin suite-name count) - (if (not (test-runner-current)) - (let ((r (test-runner-create))) - (test-runner-current r) - (test-runner-on-final! r - (let ((old-final (test-runner-on-final r))) - (lambda (r) (old-final r) (test-runner-current #f)))))) - (let ((runner (test-runner-current))) - ((test-runner-on-group-begin runner) runner suite-name count) - (%test-runner-skip-save! runner - (cons (%test-runner-skip-list runner) - (%test-runner-skip-save runner))) - (%test-runner-fail-save! runner - (cons (%test-runner-fail-list runner) - (%test-runner-fail-save runner))) - (%test-runner-count-list! runner - (cons (cons (%test-runner-total-count runner) - count) - (%test-runner-count-list runner))) - (test-runner-group-stack! runner (cons suite-name - (test-runner-group-stack runner))))) -(cond-expand - (kawa - ;; Kawa has test-begin built in, implemented as: - ;; (begin - ;; (cond-expand (srfi-64 #!void) (else (require 'srfi-64))) - ;; (%test-begin suite-name [count])) - ;; This puts test-begin but only test-begin in the default environment., - ;; which makes normal test suites loadable without non-portable commands. - ) - (else - (define-syntax test-begin - (syntax-rules () - ((test-begin suite-name) - (%test-begin suite-name #f)) - ((test-begin suite-name count) - (%test-begin suite-name count)))))) - -(define (test-on-group-begin-simple runner suite-name count) - (if (null? (test-runner-group-stack runner)) - (begin - (display "%%%% Starting test ") - (display suite-name) - (if test-log-to-file - (let* ((log-file-name - (if (string? test-log-to-file) test-log-to-file - (string-append suite-name ".log"))) - (log-file - (cond-expand (mzscheme - (open-output-file log-file-name 'truncate/replace)) - (else (open-output-file log-file-name))))) - (display "%%%% Starting test " log-file) - (display suite-name log-file) - (newline log-file) - (test-runner-aux-value! runner log-file) - (display " (Writing full log to \"") - (display log-file-name) - (display "\")"))) - (newline))) - (let ((log (test-runner-aux-value runner))) - (if (output-port? log) - (begin - (display "Group begin: " log) - (display suite-name log) - (newline log)))) - #f) - -(define (test-on-group-end-simple runner) - (let ((log (test-runner-aux-value runner))) - (if (output-port? log) - (begin - (display "Group end: " log) - (display (car (test-runner-group-stack runner)) log) - (newline log)))) - #f) - -(define (%test-on-bad-count-write runner count expected-count port) - (display "*** Total number of tests was " port) - (display count port) - (display " but should be " port) - (display expected-count port) - (display ". ***" port) - (newline port) - (display "*** Discrepancy indicates testsuite error or exceptions. ***" port) - (newline port)) - -(define (test-on-bad-count-simple runner count expected-count) - (%test-on-bad-count-write runner count expected-count (current-output-port)) - (let ((log (test-runner-aux-value runner))) - (if (output-port? log) - (%test-on-bad-count-write runner count expected-count log)))) - -(define (test-on-bad-end-name-simple runner begin-name end-name) - (let ((msg (string-append (%test-format-line runner) "test-end " begin-name - " does not match test-begin " end-name))) - (cond-expand - (srfi-23 (error msg)) - (else (display msg) (newline))))) - - -(define (%test-final-report1 value label port) - (if (> value 0) - (begin - (display label port) - (display value port) - (newline port)))) - -(define (%test-final-report-simple runner port) - (%test-final-report1 (test-runner-pass-count runner) - "# of expected passes " port) - (%test-final-report1 (test-runner-xfail-count runner) - "# of expected failures " port) - (%test-final-report1 (test-runner-xpass-count runner) - "# of unexpected successes " port) - (%test-final-report1 (test-runner-fail-count runner) - "# of unexpected failures " port) - (%test-final-report1 (test-runner-skip-count runner) - "# of skipped tests " port)) - -(define (test-on-final-simple runner) - (%test-final-report-simple runner (current-output-port)) - (let ((log (test-runner-aux-value runner))) - (if (output-port? log) - (%test-final-report-simple runner log)))) - -(define (%test-format-line runner) - (let* ((line-info (test-result-alist runner)) - (source-file (assq 'source-file line-info)) - (source-line (assq 'source-line line-info)) - (file (if source-file (cdr source-file) ""))) - (if source-line - (string-append file ":" - (number->string (cdr source-line)) ": ") - ""))) - -(define (%test-end suite-name line-info) - (let* ((r (test-runner-get)) - (groups (test-runner-group-stack r)) - (line (%test-format-line r))) - (test-result-alist! r line-info) - (if (null? groups) - (let ((msg (string-append line "test-end not in a group"))) - (cond-expand - (srfi-23 (error msg)) - (else (display msg) (newline))))) - (if (and suite-name (not (equal? suite-name (car groups)))) - ((test-runner-on-bad-end-name r) r suite-name (car groups))) - (let* ((count-list (%test-runner-count-list r)) - (expected-count (cdar count-list)) - (saved-count (caar count-list)) - (group-count (- (%test-runner-total-count r) saved-count))) - (if (and expected-count - (not (= expected-count group-count))) - ((test-runner-on-bad-count r) r group-count expected-count)) - ((test-runner-on-group-end r) r) - (test-runner-group-stack! r (cdr (test-runner-group-stack r))) - (%test-runner-skip-list! r (car (%test-runner-skip-save r))) - (%test-runner-skip-save! r (cdr (%test-runner-skip-save r))) - (%test-runner-fail-list! r (car (%test-runner-fail-save r))) - (%test-runner-fail-save! r (cdr (%test-runner-fail-save r))) - (%test-runner-count-list! r (cdr count-list)) - (if (null? (test-runner-group-stack r)) - ((test-runner-on-final r) r))))) - -(define-syntax test-group - (syntax-rules () - ((test-group suite-name . body) - (let ((r (test-runner-current))) - ;; Ideally should also set line-number, if available. - (test-result-alist! r (list (cons 'test-name suite-name))) - (if (%test-should-execute r) - (dynamic-wind - (lambda () (test-begin suite-name)) - (lambda () . body) - (lambda () (test-end suite-name)))))))) - -(define-syntax test-group-with-cleanup - (syntax-rules () - ((test-group-with-cleanup suite-name form cleanup-form) - (test-group suite-name - (dynamic-wind - (lambda () #f) - (lambda () form) - (lambda () cleanup-form)))) - ((test-group-with-cleanup suite-name cleanup-form) - (test-group-with-cleanup suite-name #f cleanup-form)) - ((test-group-with-cleanup suite-name form1 form2 form3 . rest) - (test-group-with-cleanup suite-name (begin form1 form2) form3 . rest)))) - -(define (test-on-test-begin-simple runner) - (let ((log (test-runner-aux-value runner))) - (if (output-port? log) - (let* ((results (test-result-alist runner)) - (source-file (assq 'source-file results)) - (source-line (assq 'source-line results)) - (source-form (assq 'source-form results)) - (test-name (assq 'test-name results))) - (display "Test begin:" log) - (newline log) - (if test-name (%test-write-result1 test-name log)) - (if source-file (%test-write-result1 source-file log)) - (if source-line (%test-write-result1 source-line log)) - (if source-form (%test-write-result1 source-form log)))))) - -(define-syntax test-result-ref - (syntax-rules () - ((test-result-ref runner pname) - (test-result-ref runner pname #f)) - ((test-result-ref runner pname default) - (let ((p (assq pname (test-result-alist runner)))) - (if p (cdr p) default))))) - -(define (test-on-test-end-simple runner) - (let ((log (test-runner-aux-value runner)) - (kind (test-result-ref runner 'result-kind))) - (if (memq kind '(fail xpass)) - (let* ((results (test-result-alist runner)) - (source-file (assq 'source-file results)) - (source-line (assq 'source-line results)) - (test-name (assq 'test-name results))) - (if (or source-file source-line) - (begin - (if source-file (display (cdr source-file))) - (display ":") - (if source-line (display (cdr source-line))) - (display ": "))) - (display (if (eq? kind 'xpass) "XPASS" "FAIL")) - (if test-name - (begin - (display " ") - (display (cdr test-name)))) - (newline))) - (if (output-port? log) - (begin - (display "Test end:" log) - (newline log) - (let loop ((list (test-result-alist runner))) - (if (pair? list) - (let ((pair (car list))) - ;; Write out properties not written out by on-test-begin. - (if (not (memq (car pair) - '(test-name source-file source-line source-form))) - (%test-write-result1 pair log)) - (loop (cdr list))))))))) - -(define (%test-write-result1 pair port) - (display " " port) - (display (car pair) port) - (display ": " port) - (write (cdr pair) port) - (newline port)) - -(define (test-result-set! runner pname value) - (let* ((alist (test-result-alist runner)) - (p (assq pname alist))) - (if p - (set-cdr! p value) - (test-result-alist! runner (cons (cons pname value) alist))))) - -(define (test-result-clear runner) - (test-result-alist! runner '())) - -(define (test-result-remove runner pname) - (let* ((alist (test-result-alist runner)) - (p (assq pname alist))) - (if p - (test-result-alist! runner - (let loop ((r alist)) - (if (eq? r p) (cdr r) - (cons (car r) (loop (cdr r))))))))) - -(define (test-result-kind . rest) - (let ((runner (if (pair? rest) (car rest) (test-runner-current)))) - (test-result-ref runner 'result-kind))) - -(define (test-passed? . rest) - (let ((runner (if (pair? rest) (car rest) (test-runner-get)))) - (memq (test-result-ref runner 'result-kind) '(pass xpass)))) - -(define (%test-report-result) - (let* ((r (test-runner-get)) - (result-kind (test-result-kind r))) - (case result-kind - ((pass) - (test-runner-pass-count! r (+ 1 (test-runner-pass-count r)))) - ((fail) - (test-runner-fail-count! r (+ 1 (test-runner-fail-count r)))) - ((xpass) - (test-runner-xpass-count! r (+ 1 (test-runner-xpass-count r)))) - ((xfail) - (test-runner-xfail-count! r (+ 1 (test-runner-xfail-count r)))) - (else - (test-runner-skip-count! r (+ 1 (test-runner-skip-count r))))) - (%test-runner-total-count! r (+ 1 (%test-runner-total-count r))) - ((test-runner-on-test-end r) r))) - -(cond-expand - (guile - (define-syntax %test-evaluate-with-catch - (syntax-rules () - ((%test-evaluate-with-catch test-expression) - (catch #t - (lambda () test-expression) - (lambda (key . args) - (test-result-set! (test-runner-current) 'actual-error - (cons key args)) - #f)))))) - (kawa - (define-syntax %test-evaluate-with-catch - (syntax-rules () - ((%test-evaluate-with-catch test-expression) - (try-catch test-expression - (ex - (test-result-set! (test-runner-current) 'actual-error ex) - #f)))))) - (srfi-34 - (define-syntax %test-evaluate-with-catch - (syntax-rules () - ((%test-evaluate-with-catch test-expression) - (guard (err (else #f)) test-expression))))) - (chicken - (define-syntax %test-evaluate-with-catch - (syntax-rules () - ((%test-evaluate-with-catch test-expression) - (condition-case test-expression (ex () #f)))))) - (else - (define-syntax %test-evaluate-with-catch - (syntax-rules () - ((%test-evaluate-with-catch test-expression) - test-expression))))) - -(cond-expand - ((or kawa mzscheme) - (cond-expand - (mzscheme - (define-for-syntax (%test-syntax-file form) - (let ((source (syntax-source form))) - (cond ((string? source) file) - ((path? source) (path->string source)) - (else #f))))) - (kawa - (define (%test-syntax-file form) - (syntax-source form)))) - (define (%test-source-line2 form) - (let* ((line (syntax-line form)) - (file (%test-syntax-file form)) - (line-pair (if line (list (cons 'source-line line)) '()))) - (cons (cons 'source-form (syntax-object->datum form)) - (if file (cons (cons 'source-file file) line-pair) line-pair))))) - (guile-2 - (define (%test-source-line2 form) - (let* ((src-props (syntax-source form)) - (file (and src-props (assq-ref src-props 'filename))) - (line (and src-props (assq-ref src-props 'line))) - (file-alist (if file - `((source-file . ,file)) - '())) - (line-alist (if line - `((source-line . ,(+ line 1))) - '()))) - (datum->syntax (syntax here) - `((source-form . ,(syntax->datum form)) - ,@file-alist - ,@line-alist))))) - (else - (define (%test-source-line2 form) - '()))) - -(define (%test-on-test-begin r) - (%test-should-execute r) - ((test-runner-on-test-begin r) r) - (not (eq? 'skip (test-result-ref r 'result-kind)))) - -(define (%test-on-test-end r result) - (test-result-set! r 'result-kind - (if (eq? (test-result-ref r 'result-kind) 'xfail) - (if result 'xpass 'xfail) - (if result 'pass 'fail)))) - -(define (test-runner-test-name runner) - (test-result-ref runner 'test-name "")) - -(define-syntax %test-comp2body - (syntax-rules () - ((%test-comp2body r comp expected expr) - (let () - (if (%test-on-test-begin r) - (let ((exp expected)) - (test-result-set! r 'expected-value exp) - (let ((res (%test-evaluate-with-catch expr))) - (test-result-set! r 'actual-value res) - (%test-on-test-end r (comp exp res))))) - (%test-report-result))))) - -(define (%test-approximate= error) - (lambda (value expected) - (let ((rval (real-part value)) - (ival (imag-part value)) - (rexp (real-part expected)) - (iexp (imag-part expected))) - (and (>= rval (- rexp error)) - (>= ival (- iexp error)) - (<= rval (+ rexp error)) - (<= ival (+ iexp error)))))) - -(define-syntax %test-comp1body - (syntax-rules () - ((%test-comp1body r expr) - (let () - (if (%test-on-test-begin r) - (let () - (let ((res (%test-evaluate-with-catch expr))) - (test-result-set! r 'actual-value res) - (%test-on-test-end r res)))) - (%test-report-result))))) - -(cond-expand - ((or kawa mzscheme guile-2) - ;; Should be made to work for any Scheme with syntax-case - ;; However, I haven't gotten the quoting working. FIXME. - (define-syntax test-end - (lambda (x) - (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () - (((mac suite-name) line) - (syntax - (%test-end suite-name line))) - (((mac) line) - (syntax - (%test-end #f line)))))) - (define-syntax test-assert - (lambda (x) - (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () - (((mac tname expr) line) - (syntax - (let* ((r (test-runner-get)) - (name tname)) - (test-result-alist! r (cons (cons 'test-name tname) line)) - (%test-comp1body r expr)))) - (((mac expr) line) - (syntax - (let* ((r (test-runner-get))) - (test-result-alist! r line) - (%test-comp1body r expr))))))) - (define (%test-comp2 comp x) - (syntax-case (list x (list (syntax quote) (%test-source-line2 x)) comp) () - (((mac tname expected expr) line comp) - (syntax - (let* ((r (test-runner-get)) - (name tname)) - (test-result-alist! r (cons (cons 'test-name tname) line)) - (%test-comp2body r comp expected expr)))) - (((mac expected expr) line comp) - (syntax - (let* ((r (test-runner-get))) - (test-result-alist! r line) - (%test-comp2body r comp expected expr)))))) - (define-syntax test-eqv - (lambda (x) (%test-comp2 (syntax eqv?) x))) - (define-syntax test-eq - (lambda (x) (%test-comp2 (syntax eq?) x))) - (define-syntax test-equal - (lambda (x) (%test-comp2 (syntax equal?) x))) - (define-syntax test-approximate ;; FIXME - needed for non-Kawa - (lambda (x) - (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () - (((mac tname expected expr error) line) - (syntax - (let* ((r (test-runner-get)) - (name tname)) - (test-result-alist! r (cons (cons 'test-name tname) line)) - (%test-comp2body r (%test-approximate= error) expected expr)))) - (((mac expected expr error) line) - (syntax - (let* ((r (test-runner-get))) - (test-result-alist! r line) - (%test-comp2body r (%test-approximate= error) expected expr)))))))) - (else - (define-syntax test-end - (syntax-rules () - ((test-end) - (%test-end #f '())) - ((test-end suite-name) - (%test-end suite-name '())))) - (define-syntax test-assert - (syntax-rules () - ((test-assert tname test-expression) - (let* ((r (test-runner-get)) - (name tname)) - (test-result-alist! r '((test-name . tname))) - (%test-comp1body r test-expression))) - ((test-assert test-expression) - (let* ((r (test-runner-get))) - (test-result-alist! r '()) - (%test-comp1body r test-expression))))) - (define-syntax %test-comp2 - (syntax-rules () - ((%test-comp2 comp tname expected expr) - (let* ((r (test-runner-get)) - (name tname)) - (test-result-alist! r (list (cons 'test-name tname))) - (%test-comp2body r comp expected expr))) - ((%test-comp2 comp expected expr) - (let* ((r (test-runner-get))) - (test-result-alist! r '()) - (%test-comp2body r comp expected expr))))) - (define-syntax test-equal - (syntax-rules () - ((test-equal . rest) - (%test-comp2 equal? . rest)))) - (define-syntax test-eqv - (syntax-rules () - ((test-eqv . rest) - (%test-comp2 eqv? . rest)))) - (define-syntax test-eq - (syntax-rules () - ((test-eq . rest) - (%test-comp2 eq? . rest)))) - (define-syntax test-approximate - (syntax-rules () - ((test-approximate tname expected expr error) - (%test-comp2 (%test-approximate= error) tname expected expr)) - ((test-approximate expected expr error) - (%test-comp2 (%test-approximate= error) expected expr)))))) - -(cond-expand - (guile - (define-syntax %test-error - (syntax-rules () - ((%test-error r etype expr) - (cond ((%test-on-test-begin r) - (let ((et etype)) - (test-result-set! r 'expected-error et) - (%test-on-test-end r - (catch #t - (lambda () - (test-result-set! r 'actual-value expr) - #f) - (lambda (key . args) - ;; TODO: decide how to specify expected - ;; error types for Guile. - (test-result-set! r 'actual-error - (cons key args)) - #t))) - (%test-report-result)))))))) - (mzscheme - (define-syntax %test-error - (syntax-rules () - ((%test-error r etype expr) - (%test-comp1body r (with-handlers (((lambda (h) #t) (lambda (h) #t))) - (let () - (test-result-set! r 'actual-value expr) - #f))))))) - (chicken - (define-syntax %test-error - (syntax-rules () - ((%test-error r etype expr) - (%test-comp1body r (condition-case expr (ex () #t))))))) - (kawa - (define-syntax %test-error - (syntax-rules () - ((%test-error r #t expr) - (cond ((%test-on-test-begin r) - (test-result-set! r 'expected-error #t) - (%test-on-test-end r - (try-catch - (let () - (test-result-set! r 'actual-value expr) - #f) - (ex - (test-result-set! r 'actual-error ex) - #t))) - (%test-report-result)))) - ((%test-error r etype expr) - (if (%test-on-test-begin r) - (let ((et etype)) - (test-result-set! r 'expected-error et) - (%test-on-test-end r - (try-catch - (let () - (test-result-set! r 'actual-value expr) - #f) - (ex - (test-result-set! r 'actual-error ex) - (cond ((and (instance? et ) - (gnu.bytecode.ClassType:isSubclass et )) - (instance? ex et)) - (else #t))))) - (%test-report-result))))))) - ((and srfi-34 srfi-35) - (define-syntax %test-error - (syntax-rules () - ((%test-error r etype expr) - (%test-comp1body r (guard (ex ((condition-type? etype) - (and (condition? ex) (condition-has-type? ex etype))) - ((procedure? etype) - (etype ex)) - ((equal? etype #t) - #t) - (else #t)) - expr #f)))))) - (srfi-34 - (define-syntax %test-error - (syntax-rules () - ((%test-error r etype expr) - (%test-comp1body r (guard (ex (else #t)) expr #f)))))) - (else - (define-syntax %test-error - (syntax-rules () - ((%test-error r etype expr) - (begin - ((test-runner-on-test-begin r) r) - (test-result-set! r 'result-kind 'skip) - (%test-report-result))))))) - -(cond-expand - ((or kawa mzscheme guile-2) - - (define-syntax test-error - (lambda (x) - (syntax-case (list x (list (syntax quote) (%test-source-line2 x))) () - (((mac tname etype expr) line) - (syntax - (let* ((r (test-runner-get)) - (name tname)) - (test-result-alist! r (cons (cons 'test-name tname) line)) - (%test-error r etype expr)))) - (((mac etype expr) line) - (syntax - (let* ((r (test-runner-get))) - (test-result-alist! r line) - (%test-error r etype expr)))) - (((mac expr) line) - (syntax - (let* ((r (test-runner-get))) - (test-result-alist! r line) - (%test-error r #t expr)))))))) - (else - (define-syntax test-error - (syntax-rules () - ((test-error name etype expr) - (let ((r (test-runner-get))) - (test-result-alist! r `((test-name . ,name))) - (%test-error r etype expr))) - ((test-error etype expr) - (let ((r (test-runner-get))) - (test-result-alist! r '()) - (%test-error r etype expr))) - ((test-error expr) - (let ((r (test-runner-get))) - (test-result-alist! r '()) - (%test-error r #t expr))))))) - -(define (test-apply first . rest) - (if (test-runner? first) - (test-with-runner first (apply test-apply rest)) - (let ((r (test-runner-current))) - (if r - (let ((run-list (%test-runner-run-list r))) - (cond ((null? rest) - (%test-runner-run-list! r (reverse run-list)) - (first)) ;; actually apply procedure thunk - (else - (%test-runner-run-list! - r - (if (eq? run-list #t) (list first) (cons first run-list))) - (apply test-apply rest) - (%test-runner-run-list! r run-list)))) - (let ((r (test-runner-create))) - (test-with-runner r (apply test-apply first rest)) - ((test-runner-on-final r) r)))))) - -(define-syntax test-with-runner - (syntax-rules () - ((test-with-runner runner form ...) - (let ((saved-runner (test-runner-current))) - (dynamic-wind - (lambda () (test-runner-current runner)) - (lambda () form ...) - (lambda () (test-runner-current saved-runner))))))) - -;;; Predicates - -(define (%test-match-nth n count) - (let ((i 0)) - (lambda (runner) - (set! i (+ i 1)) - (and (>= i n) (< i (+ n count)))))) - -(define-syntax test-match-nth - (syntax-rules () - ((test-match-nth n) - (test-match-nth n 1)) - ((test-match-nth n count) - (%test-match-nth n count)))) - -(define (%test-match-all . pred-list) - (lambda (runner) - (let ((result #t)) - (let loop ((l pred-list)) - (if (null? l) - result - (begin - (if (not ((car l) runner)) - (set! result #f)) - (loop (cdr l)))))))) - -(define-syntax test-match-all - (syntax-rules () - ((test-match-all pred ...) - (%test-match-all (%test-as-specifier pred) ...)))) - -(define (%test-match-any . pred-list) - (lambda (runner) - (let ((result #f)) - (let loop ((l pred-list)) - (if (null? l) - result - (begin - (if ((car l) runner) - (set! result #t)) - (loop (cdr l)))))))) - -(define-syntax test-match-any - (syntax-rules () - ((test-match-any pred ...) - (%test-match-any (%test-as-specifier pred) ...)))) - -;; Coerce to a predicate function: -(define (%test-as-specifier specifier) - (cond ((procedure? specifier) specifier) - ((integer? specifier) (test-match-nth 1 specifier)) - ((string? specifier) (test-match-name specifier)) - (else - (error "not a valid test specifier")))) - -(define-syntax test-skip - (syntax-rules () - ((test-skip pred ...) - (let ((runner (test-runner-get))) - (%test-runner-skip-list! runner - (cons (test-match-all (%test-as-specifier pred) ...) - (%test-runner-skip-list runner))))))) - -(define-syntax test-expect-fail - (syntax-rules () - ((test-expect-fail pred ...) - (let ((runner (test-runner-get))) - (%test-runner-fail-list! runner - (cons (test-match-all (%test-as-specifier pred) ...) - (%test-runner-fail-list runner))))))) - -(define (test-match-name name) - (lambda (runner) - (equal? name (test-runner-test-name runner)))) - -(define (test-read-eval-string string) - (let* ((port (open-input-string string)) - (form (read port))) - (if (eof-object? (read-char port)) - (cond-expand - (guile (eval form (current-module))) - (else (eval form))) - (cond-expand - (srfi-23 (error "(not at eof)")) - (else "error"))))) - diff --git a/test-suite/tests/srfi-64-test.scm b/test-suite/tests/srfi-64-test.scm index ca0b58943..beb5129b7 100644 --- a/test-suite/tests/srfi-64-test.scm +++ b/test-suite/tests/srfi-64-test.scm @@ -716,7 +716,7 @@ (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)) + '(("w" "p" "v") () () () () (3 0 0 0 0)) (triv-runner (lambda () (test-begin "a") @@ -733,7 +733,7 @@ (test-assert "v" #t)))) (test-equal "8.6.2. Simple (form 2) test-apply" - '(("w" "p" "v") () () () ("x") (3 0 0 0 1)) + '(("w" "p" "v") () () () () (3 0 0 0 0)) (triv-runner (lambda () (test-begin "a")