From a2ef24da83746ee91d7a2f5e494acc95faa71fec Mon Sep 17 00:00:00 2001 From: Taylan Kammer Date: Mon, 10 May 2021 15:23:17 +0200 Subject: [PATCH 1/2] Use a different SRFI-64 implementation. * module/srfi/srfi-64.scm: Add imports and other boilerplate for new implementation. * module/srfi/srfi-64/execution.body.scm: New file. * module/srfi/srfi-64/source-info.body.scm: New file. * module/srfi/srfi-64/test-runner-simple.body.scm: New file. * module/srfi/srfi-64/test-runner.body.scm: New file. * module/srfi/srfi-64/testing.scm: Deleted. * module/Makefile.am (srfi-64.go, NOCOMP_SOURCES): Change accordingly. --- module/Makefile.am | 11 +- module/srfi/srfi-64.scm | 17 +- module/srfi/srfi-64/execution.body.scm | 434 +++++++ module/srfi/srfi-64/source-info.body.scm | 88 ++ .../srfi/srfi-64/test-runner-simple.body.scm | 173 +++ module/srfi/srfi-64/test-runner.body.scm | 168 +++ module/srfi/srfi-64/testing.scm | 1044 ----------------- 7 files changed, 885 insertions(+), 1050 deletions(-) create mode 100644 module/srfi/srfi-64/execution.body.scm create mode 100644 module/srfi/srfi-64/source-info.body.scm create mode 100644 module/srfi/srfi-64/test-runner-simple.body.scm create mode 100644 module/srfi/srfi-64/test-runner.body.scm delete mode 100644 module/srfi/srfi-64/testing.scm diff --git a/module/Makefile.am b/module/Makefile.am index 37786ed42..5710d005d 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -29,7 +29,11 @@ $(VM_TARGETS): $(top_builddir)/libguile/vm-operations.h 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 +srfi/srfi-64.go: srfi/srfi-64.scm \ + srfi/srfi-64/execution.body.scm \ + srfi/srfi-64/source-info.body.scm \ + srfi/srfi-64/test-runner-simple.body.scm \ + srfi/srfi-64/test-runner.body.scm $(nobase_ccache_DATA): ../bootstrap/ice-9/eval.go # Keep this rule in sync with that in `am/guilec'. @@ -405,7 +409,10 @@ NOCOMP_SOURCES = \ ice-9/r7rs-libraries.scm \ ice-9/quasisyntax.scm \ srfi/srfi-42/ec.scm \ - srfi/srfi-64/testing.scm \ + srfi/srfi-64/execution.body.scm \ + srfi/srfi-64/source-info.body.scm \ + srfi/srfi-64/test-runner-simple.body.scm \ + srfi/srfi-64/test-runner.body.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..e6c6ce80a 100644 --- a/module/srfi/srfi-64.scm +++ b/module/srfi/srfi-64.scm @@ -24,9 +24,9 @@ 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-exit 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 @@ -48,9 +48,18 @@ 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 + test-on-final-simple)) (cond-expand-provide (current-module) '(srfi-64)) -(include-from-path "srfi/srfi-64/testing.scm") +(import + (only (rnrs exceptions) guard) + (srfi srfi-1) + (srfi srfi-9) + (srfi srfi-11) + (srfi srfi-35)) + +(include-from-path "srfi/srfi-64/source-info.body.scm") +(include-from-path "srfi/srfi-64/test-runner.body.scm") +(include-from-path "srfi/srfi-64/test-runner-simple.body.scm") +(include-from-path "srfi/srfi-64/execution.body.scm") diff --git a/module/srfi/srfi-64/execution.body.scm b/module/srfi/srfi-64/execution.body.scm new file mode 100644 index 000000000..922e12a6d --- /dev/null +++ b/module/srfi/srfi-64/execution.body.scm @@ -0,0 +1,434 @@ +;; 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. +;; Refactored by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014, 2015. +;; +;; 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. + +;;; Note: to prevent producing massive amounts of code from the macro-expand +;;; phase (which makes compile times suffer and may hit code size limits in some +;;; systems), keep macro bodies minimal by delegating work to procedures. + + +;;; Grouping + +(define (maybe-install-default-runner suite-name) + (when (not (test-runner-current)) + (let* ((log-file (string-append suite-name ".srfi64.log")) + (runner (test-runner-simple log-file))) + (%test-runner-auto-installed! runner #t) + (test-runner-current runner)))) + +(define (maybe-uninstall-default-runner) + (when (%test-runner-auto-installed? (test-runner-current)) + (test-runner-current #f))) + +(define test-begin + (case-lambda + ((name) + (test-begin name #f)) + ((name count) + (maybe-install-default-runner name) + (let ((r (test-runner-current))) + (let ((skip-list (%test-runner-skip-list r)) + (skip-save (%test-runner-skip-save r)) + (fail-list (%test-runner-fail-list r)) + (fail-save (%test-runner-fail-save r)) + (total-count (%test-runner-total-count r)) + (count-list (%test-runner-count-list r)) + (group-stack (test-runner-group-stack r))) + ((test-runner-on-group-begin r) r name count) + (%test-runner-skip-save! r (cons skip-list skip-save)) + (%test-runner-fail-save! r (cons fail-list fail-save)) + (%test-runner-count-list! r (cons (cons total-count count) + count-list)) + (test-runner-group-stack! r (cons name group-stack))))))) + +(define test-end + (case-lambda + (() + (test-end #f)) + ((name) + (let* ((r (test-runner-get)) + (groups (test-runner-group-stack r))) + (test-result-clear r) + (when (null? groups) + (error "test-end not in a group")) + (when (and name (not (equal? name (car groups)))) + ((test-runner-on-bad-end-name r) r 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))) + (when (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)) + (when (null? (test-runner-group-stack r)) + ((test-runner-on-final r) r) + (maybe-uninstall-default-runner))))))) + +(define-syntax test-group + (syntax-rules () + ((_ . *) + (%test-group (lambda () . *))))) + +(define (%test-group name thunk) + (begin + (maybe-install-default-runner name) + (let ((runner (test-runner-get))) + (test-result-clear runner) + (test-result-set! runner 'name name) + (unless (test-skip? runner) + (dynamic-wind + (lambda () (test-begin name)) + thunk + (lambda () (test-end name))))))) + +(define-syntax test-group-with-cleanup + (syntax-rules () + ((_ * ... ) + (test-group + (dynamic-wind (lambda () #f) + (lambda () * ...) + (lambda () )))))) + + +;;; Skipping, expected-failing, matching + +(define (test-skip . specs) + (let ((runner (test-runner-get))) + (%test-runner-skip-list! + runner (cons (apply test-match-all specs) + (%test-runner-skip-list runner))))) + +(define (test-skip? runner) + (let ((run-list (%test-runner-run-list runner)) + (skip-list (%test-runner-skip-list runner))) + (or (and run-list (not (any-pred run-list runner))) + (any-pred skip-list runner)))) + +(define (test-expect-fail . specs) + (let ((runner (test-runner-get))) + (%test-runner-fail-list! + runner (cons (apply test-match-all specs) + (%test-runner-fail-list runner))))) + +(define (test-match-any . specs) + (let ((preds (map make-pred specs))) + (lambda (runner) + (any-pred preds runner)))) + +(define (test-match-all . specs) + (let ((preds (map make-pred specs))) + (lambda (runner) + (every-pred preds runner)))) + +(define (make-pred spec) + (cond + ((procedure? spec) + spec) + ((integer? spec) + (test-match-nth 1 spec)) + ((string? spec) + (test-match-name spec)) + (else + (error "not a valid test specifier" spec)))) + +(define test-match-nth + (case-lambda + ((n) (test-match-nth n 1)) + ((n count) + (let ((i 0)) + (lambda (runner) + (set! i (+ i 1)) + (and (>= i n) (< i (+ n count)))))))) + +(define (test-match-name name) + (lambda (runner) + (equal? name (test-runner-test-name runner)))) + +;;; Beware: all predicates must be called because they might have side-effects; +;;; no early returning or and/or short-circuiting of procedure calls allowed. + +(define (any-pred preds object) + (let loop ((matched? #f) + (preds preds)) + (if (null? preds) + matched? + (let ((result ((car preds) object))) + (loop (or matched? result) + (cdr preds)))))) + +(define (every-pred preds object) + (let loop ((failed? #f) + (preds preds)) + (if (null? preds) + (not failed?) + (let ((result ((car preds) object))) + (loop (or failed? (not result)) + (cdr preds)))))) + +;;; Actual testing + +(define-syntax false-if-error + (syntax-rules () + ((_ ) + (guard (error + (else + (test-result-set! 'actual-error error) + #f)) + )))) + +(define (test-prelude source-info runner name form) + (test-result-clear runner) + (set-source-info! runner source-info) + (when name + (test-result-set! runner 'name name)) + (test-result-set! runner 'source-form form) + (let ((skip? (test-skip? runner))) + (if skip? + (test-result-set! runner 'result-kind 'skip) + (let ((fail-list (%test-runner-fail-list runner))) + (when (any-pred fail-list runner) + ;; For later inspection only. + (test-result-set! runner 'result-kind 'xfail)))) + ((test-runner-on-test-begin runner) runner) + (not skip?))) + +(define (test-postlude runner) + (let ((result-kind (test-result-kind runner))) + (case result-kind + ((pass) + (test-runner-pass-count! runner (+ 1 (test-runner-pass-count runner)))) + ((fail) + (test-runner-fail-count! runner (+ 1 (test-runner-fail-count runner)))) + ((xpass) + (test-runner-xpass-count! runner (+ 1 (test-runner-xpass-count runner)))) + ((xfail) + (test-runner-xfail-count! runner (+ 1 (test-runner-xfail-count runner)))) + ((skip) + (test-runner-skip-count! runner (+ 1 (test-runner-skip-count runner))))) + (%test-runner-total-count! runner (+ 1 (%test-runner-total-count runner))) + ((test-runner-on-test-end runner) runner))) + +(define (set-result-kind! runner pass?) + (test-result-set! runner 'result-kind + (if (eq? (test-result-kind runner) 'xfail) + (if pass? 'xpass 'xfail) + (if pass? 'pass 'fail)))) + +;;; We need to use some trickery to get the source info right. The important +;;; thing is to pass a syntax object that is a pair to `source-info', and make +;;; sure this syntax object comes from user code and not from ourselves. + +(define-syntax test-assert + (syntax-rules () + ((_ . ) + (test-assert/source-info (source-info ) . )))) + +(define-syntax test-assert/source-info + (syntax-rules () + ((_ ) + (test-assert/source-info #f )) + ((_ ) + (%test-assert ' (lambda () ))))) + +(define (%test-assert source-info name form thunk) + (let ((runner (test-runner-get))) + (when (test-prelude source-info runner name form) + (let ((val (false-if-error (thunk) runner))) + (test-result-set! runner 'actual-value val) + (set-result-kind! runner val))) + (test-postlude runner))) + +(define-syntax test-compare + (syntax-rules () + ((_ . ) + (test-compare/source-info (source-info ) . )))) + +(define-syntax test-compare/source-info + (syntax-rules () + ((_ ) + (test-compare/source-info #f )) + ((_ ) + (%test-compare ' + (lambda () ))))) + +(define (%test-compare source-info compare name expected form thunk) + (let ((runner (test-runner-get))) + (when (test-prelude source-info runner name form) + (test-result-set! runner 'expected-value expected) + (let ((pass? (false-if-error + (let ((val (thunk))) + (test-result-set! runner 'actual-value val) + (compare expected val)) + runner))) + (set-result-kind! runner pass?))) + (test-postlude runner))) + +(define-syntax test-equal + (syntax-rules () + ((_ . ) + (test-compare/source-info (source-info ) equal? . )))) + +(define-syntax test-eqv + (syntax-rules () + ((_ . ) + (test-compare/source-info (source-info ) eqv? . )))) + +(define-syntax test-eq + (syntax-rules () + ((_ . ) + (test-compare/source-info (source-info ) eq? . )))) + +(define (approx= margin) + (lambda (value expected) + (let ((rval (real-part value)) + (ival (imag-part value)) + (rexp (real-part expected)) + (iexp (imag-part expected))) + (and (>= rval (- rexp margin)) + (>= ival (- iexp margin)) + (<= rval (+ rexp margin)) + (<= ival (+ iexp margin)))))) + +(define-syntax test-approximate + (syntax-rules () + ((_ . ) + (test-approximate/source-info (source-info ) . )))) + +(define-syntax test-approximate/source-info + (syntax-rules () + ((_ ) + (test-approximate/source-info + #f )) + ((_ ) + (test-compare/source-info + (approx= ) )))) + +(define (error-matches? error type) + (cond + ((eq? type #t) + #t) + ((condition-type? type) + (and (condition? error) (condition-has-type? error type))) + ((procedure? type) + (type error)) + (else + (let ((runner (test-runner-get))) + ((%test-runner-on-bad-error-type runner) runner type error)) + #f))) + +(define-syntax test-error + (syntax-rules () + ((_ . ) + (test-error/source-info (source-info ) . )))) + +(define-syntax test-error/source-info + (syntax-rules () + ((_ ) + (test-error/source-info #f #t )) + ((_ ) + (test-error/source-info #f )) + ((_ ) + (%test-error ' + (lambda () ))))) + +(define (%test-error source-info name error-type form thunk) + (let ((runner (test-runner-get))) + (when (test-prelude source-info runner name form) + (test-result-set! runner 'expected-error error-type) + (let ((pass? (guard (error (else (test-result-set! + runner 'actual-error error) + (error-matches? error error-type))) + (let ((val (thunk))) + (test-result-set! runner 'actual-value val)) + #f))) + (set-result-kind! runner pass?))) + (test-postlude runner))) + +(define (default-module) + (cond-expand + (guile (current-module)) + (else #f))) + +(define test-read-eval-string + (case-lambda + ((string) + (test-read-eval-string string (default-module))) + ((string env) + (let* ((port (open-input-string string)) + (form (read port))) + (if (eof-object? (read-char port)) + (if env + (eval form env) + (eval form)) + (error "(not at eof)")))))) + + +;;; Test runner control flow + +(define-syntax test-with-runner + (syntax-rules () + ((_ . *) + (let ((saved-runner (test-runner-current))) + (dynamic-wind + (lambda () (test-runner-current )) + (lambda () . *) + (lambda () (test-runner-current saved-runner))))))) + +(define (test-apply first . rest) + (let ((runner (if (test-runner? first) + first + (or (test-runner-current) (test-runner-create)))) + (run-list (if (test-runner? first) + (drop-right rest 1) + (cons first (drop-right rest 1)))) + (proc (last rest))) + (test-with-runner runner + (let ((saved-run-list (%test-runner-run-list runner))) + (%test-runner-run-list! runner run-list) + (proc) + (%test-runner-run-list! runner saved-run-list))))) + + +;;; Indicate success/failure via exit status + +(define (test-exit) + (let ((runner (test-runner-current))) + (when (not runner) + (error "No test runner installed. Might have been auto-removed +by test-end if you had not installed one explicitly.")) + (if (and (zero? (test-runner-xpass-count runner)) + (zero? (test-runner-fail-count runner))) + (exit 0) + (exit 1)))) + +;;; execution.scm ends here diff --git a/module/srfi/srfi-64/source-info.body.scm b/module/srfi/srfi-64/source-info.body.scm new file mode 100644 index 000000000..684873587 --- /dev/null +++ b/module/srfi/srfi-64/source-info.body.scm @@ -0,0 +1,88 @@ +;; Copyright (c) 2015 Taylan Ulrich Bayırlı/Kammer +;; +;; 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. + +;;; In some systems, a macro use like (source-info ...), that resides in a +;;; syntax-rules macro body, first gets inserted into the place where the +;;; syntax-rules macro was used, and then the transformer of 'source-info' is +;;; called with a syntax object that has the source location information of that +;;; position. That works fine when the user calls e.g. (test-assert ...), whose +;;; body contains (source-info ...); the user gets the source location of the +;;; (test-assert ...) call as intended, and not the source location of the real +;;; (source-info ...) call. + +;;; In other systems, *first* the (source-info ...) is processed to get its real +;;; position, which is within the body of a syntax-rules macro like test-assert, +;;; so no matter where the user calls (test-assert ...), they get source +;;; location information of where we defined test-assert with the call to +;;; (source-info ...) in its body. That's arguably more correct behavior, +;;; although in this case it makes our job a bit harder; we need to get the +;;; source location from an argument to 'source-info' instead. + +(define (canonical-syntax form arg) + (cond-expand + (kawa arg) + (guile-2 form) + (else #f))) + +(cond-expand + ((or kawa guile-2) + (define-syntax source-info + (lambda (stx) + (syntax-case stx () + ((_ ) + (let* ((stx (canonical-syntax stx (syntax ))) + (file (syntax-source-file stx)) + (line (syntax-source-line stx))) + (quasisyntax + (cons (unsyntax file) (unsyntax line))))))))) + (else + (define-syntax source-info + (syntax-rules () + ((_ ) + #f))))) + +(define (syntax-source-file stx) + (cond-expand + (kawa + (syntax-source stx)) + (guile-2 + (let ((source (syntax-source stx))) + (and source (assq-ref source 'filename)))) + (else + #f))) + +(define (syntax-source-line stx) + (cond-expand + (kawa + (syntax-line stx)) + (guile-2 + (let ((source (syntax-source stx))) + (and source (assq-ref source 'line)))) + (else + #f))) + +(define (set-source-info! runner source-info) + (when source-info + (test-result-set! runner 'source-file (car source-info)) + (test-result-set! runner 'source-line (cdr source-info)))) + +;;; source-info.body.scm ends here diff --git a/module/srfi/srfi-64/test-runner-simple.body.scm b/module/srfi/srfi-64/test-runner-simple.body.scm new file mode 100644 index 000000000..870b314dc --- /dev/null +++ b/module/srfi/srfi-64/test-runner-simple.body.scm @@ -0,0 +1,173 @@ +;; 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. +;; Refactored by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014, 2015. +;; +;; 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. + +;;; Helpers + +(define (string-join strings delimiter) + (if (null? strings) + "" + (let loop ((result (car strings)) + (rest (cdr strings))) + (if (null? rest) + result + (loop (string-append result delimiter (car rest)) + (cdr rest)))))) + +(define (truncate-string string length) + (define (newline->space c) (if (char=? #\newline c) #\space c)) + (let* ((string (string-map newline->space string)) + (fill "...") + (fill-len (string-length fill)) + (string-len (string-length string))) + (if (<= string-len (+ length fill-len)) + string + (let-values (((q r) (floor/ length 4))) + ;; Left part gets 3/4 plus the remainder. + (let ((left-end (+ (* q 3) r)) + (right-start (- string-len q))) + (string-append (substring string 0 left-end) + fill + (substring string right-start string-len))))))) + +(define (print runner format-string . args) + (apply format #t format-string args) + (let ((port (%test-runner-log-port runner))) + (when port + (apply format port format-string args)))) + +;;; Main + +(define test-runner-simple + (case-lambda + (() + (test-runner-simple #f)) + ((log-file) + (let ((runner (test-runner-null))) + (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) + (%test-runner-on-bad-error-type! runner on-bad-error-type) + (%test-runner-log-file! runner log-file) + runner)))) + +(when (not (test-runner-factory)) + (test-runner-factory test-runner-simple)) + +(define (test-on-group-begin-simple runner name count) + (when (null? (test-runner-group-stack runner)) + (maybe-start-logging runner) + (print runner "Test suite begin: ~a~%" name))) + +(define (test-on-group-end-simple runner) + (let ((name (car (test-runner-group-stack runner)))) + (when (= 1 (length (test-runner-group-stack runner))) + (print runner "Test suite end: ~a~%" name)))) + +(define (test-on-final-simple runner) + (print runner "Passes: ~a\n" (test-runner-pass-count runner)) + (print runner "Expected failures: ~a\n" (test-runner-xfail-count runner)) + (print runner "Failures: ~a\n" (test-runner-fail-count runner)) + (print runner "Unexpected passes: ~a\n" (test-runner-xpass-count runner)) + (print runner "Skipped tests: ~a~%" (test-runner-skip-count runner)) + (maybe-finish-logging runner)) + +(define (maybe-start-logging runner) + (let ((log-file (%test-runner-log-file runner))) + (when log-file + ;; The possible race-condition here doesn't bother us. + (when (file-exists? log-file) + (delete-file log-file)) + (%test-runner-log-port! runner (open-output-file log-file)) + (print runner "Writing log file: ~a~%" log-file)))) + +(define (maybe-finish-logging runner) + (let ((log-file (%test-runner-log-file runner))) + (when log-file + (print runner "Wrote log file: ~a~%" log-file) + (close-output-port (%test-runner-log-port runner))))) + +(define (test-on-test-begin-simple runner) + (values)) + +(define (test-on-test-end-simple runner) + (let* ((result-kind (test-result-kind runner)) + (result-kind-name (case result-kind + ((pass) "PASS") ((fail) "FAIL") + ((xpass) "XPASS") ((xfail) "XFAIL") + ((skip) "SKIP"))) + (name (let ((name (test-runner-test-name runner))) + (if (string=? "" name) + (truncate-string + (format #f "~a" (test-result-ref runner 'source-form)) + 30) + name))) + (label (string-join (append (test-runner-group-path runner) + (list name)) + ": "))) + (print runner "[~a] ~a~%" result-kind-name label) + (when (memq result-kind '(fail xpass)) + (let ((nil (cons #f #f))) + (define (found? value) + (not (eq? nil value))) + (define (maybe-print value message) + (when (found? value) + (print runner message value))) + (let ((file (test-result-ref runner 'source-file "(unknown file)")) + (line (test-result-ref runner 'source-line "(unknown line)")) + (expression (test-result-ref runner 'source-form)) + (expected-value (test-result-ref runner 'expected-value nil)) + (actual-value (test-result-ref runner 'actual-value nil)) + (expected-error (test-result-ref runner 'expected-error nil)) + (actual-error (test-result-ref runner 'actual-error nil))) + (print runner "~a:~a: ~s~%" file line expression) + (maybe-print expected-value "Expected value: ~s~%") + (maybe-print expected-error "Expected error: ~a~%") + (when (or (found? expected-value) (found? expected-error)) + (maybe-print actual-value "Returned value: ~s~%")) + (maybe-print actual-error "Raised error: ~a~%") + (newline)))))) + +(define (test-on-bad-count-simple runner count expected-count) + (print runner "*** Total number of tests was ~a but should be ~a. ***~%" + count expected-count) + (print runner + "*** Discrepancy indicates testsuite error or exceptions. ***~%")) + +(define (test-on-bad-end-name-simple runner begin-name end-name) + (error (format #f "Test-end \"~a\" does not match test-begin \"~a\"." + end-name begin-name))) + +(define (on-bad-error-type runner type error) + (print runner "WARNING: unknown error type predicate: ~a~%" type) + (print runner " error was: ~a~%" error)) + +;;; test-runner-simple.scm ends here diff --git a/module/srfi/srfi-64/test-runner.body.scm b/module/srfi/srfi-64/test-runner.body.scm new file mode 100644 index 000000000..bde7e502e --- /dev/null +++ b/module/srfi/srfi-64/test-runner.body.scm @@ -0,0 +1,168 @@ +;; 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. +;; Refactored by Taylan Ulrich Bayırlı/Kammer, Copyright (c) 2014, 2015. +;; +;; 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. + + +;;; The data type + +(define-record-type + (make-test-runner) test-runner? + + (result-alist test-result-alist test-result-alist!) + + (pass-count test-runner-pass-count test-runner-pass-count!) + (fail-count test-runner-fail-count test-runner-fail-count!) + (xpass-count test-runner-xpass-count test-runner-xpass-count!) + (xfail-count test-runner-xfail-count test-runner-xfail-count!) + (skip-count test-runner-skip-count test-runner-skip-count!) + (total-count %test-runner-total-count %test-runner-total-count!) + + ;; Stack (list) of (count-at-start . expected-count): + (count-list %test-runner-count-list %test-runner-count-list!) + + ;; Normally #f, except when in a test-apply. + (run-list %test-runner-run-list %test-runner-run-list!) + + (skip-list %test-runner-skip-list %test-runner-skip-list!) + (fail-list %test-runner-fail-list %test-runner-fail-list!) + + (skip-save %test-runner-skip-save %test-runner-skip-save!) + (fail-save %test-runner-fail-save %test-runner-fail-save!) + + (group-stack test-runner-group-stack test-runner-group-stack!) + + ;; Note: on-test-begin and on-test-end are unrelated to the test-begin and + ;; test-end forms in the execution library. They're called at the + ;; beginning/end of each individual test, whereas the test-begin and test-end + ;; forms demarcate test groups. + + (on-group-begin test-runner-on-group-begin test-runner-on-group-begin!) + (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!) + (on-group-end test-runner-on-group-end test-runner-on-group-end!) + (on-final test-runner-on-final test-runner-on-final!) + (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-bad-error-type %test-runner-on-bad-error-type + %test-runner-on-bad-error-type!) + + (aux-value test-runner-aux-value test-runner-aux-value!) + + (auto-installed %test-runner-auto-installed? %test-runner-auto-installed!) + + (log-file %test-runner-log-file %test-runner-log-file!) + (log-port %test-runner-log-port %test-runner-log-port!)) + +(define (test-runner-group-path runner) + (reverse (test-runner-group-stack runner))) + +(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 #f) + (%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-null) + (define (test-null-callback . args) #f) + (let ((runner (make-test-runner))) + (test-runner-reset runner) + (test-runner-on-group-begin! runner test-null-callback) + (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 test-null-callback) + (test-runner-on-bad-end-name! runner test-null-callback) + (%test-runner-on-bad-error-type! runner test-null-callback) + (%test-runner-auto-installed! runner #f) + (%test-runner-log-file! runner #f) + (%test-runner-log-port! runner #f) + runner)) + + +;;; State + +(define test-result-ref + (case-lambda + ((runner key) + (test-result-ref runner key #f)) + ((runner key default) + (let ((entry (assq key (test-result-alist runner)))) + (if entry (cdr entry) default))))) + +(define (test-result-set! runner key value) + (let* ((alist (test-result-alist runner)) + (entry (assq key alist))) + (if entry + (set-cdr! entry value) + (test-result-alist! runner (cons (cons key value) alist))))) + +(define (test-result-remove runner key) + (test-result-alist! runner (remove (lambda (entry) + (eq? key (car entry))) + (test-result-alist runner)))) + +(define (test-result-clear runner) + (test-result-alist! runner '())) + +(define (test-runner-test-name runner) + (or (test-result-ref runner 'name) "")) + +(define test-result-kind + (case-lambda + (() (test-result-kind (test-runner-get))) + ((runner) (test-result-ref runner 'result-kind)))) + +(define test-passed? + (case-lambda + (() (test-passed? (test-runner-get))) + ((runner) (memq (test-result-kind runner) '(pass xpass))))) + + +;;; Factory and current instance + +(define test-runner-factory (make-parameter #f)) + +(define (test-runner-create) ((test-runner-factory))) + +(define test-runner-current (make-parameter #f)) + +(define (test-runner-get) + (or (test-runner-current) + (error "test-runner not initialized - test-begin missing?"))) + +;;; test-runner.scm ends here 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"))))) - -- 2.30.2