From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.org!not-for-mail From: taylanbayirli@gmail.com (Taylan Ulrich =?utf-8?Q?Bay=C4=B1rl=C4=B1?= =?utf-8?Q?=2FKammer?=) Newsgroups: gmane.lisp.guile.devel Subject: Re: [PATCH] Switch to modernized SRFI-64 implementation. Date: Fri, 02 Oct 2015 12:27:39 +0200 Message-ID: <87mvw1woo4.fsf@T420.taylan> References: <87a8t5drak.fsf@T420.taylan> <87lhbyx0q3.fsf@T420.taylan> <87h9mmwo2y.fsf@T420.taylan> <87mvwet7jl.fsf@T420.taylan> NNTP-Posting-Host: plane.gmane.org Mime-Version: 1.0 Content-Type: multipart/mixed; boundary="=-=-=" X-Trace: ger.gmane.org 1443785915 3313 80.91.229.3 (2 Oct 2015 11:38:35 GMT) X-Complaints-To: usenet@ger.gmane.org NNTP-Posting-Date: Fri, 2 Oct 2015 11:38:35 +0000 (UTC) To: guile-devel@gnu.org Original-X-From: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Fri Oct 02 13:38:31 2015 Return-path: Envelope-to: guile-devel@m.gmane.org Original-Received: from lists.gnu.org ([208.118.235.17]) by plane.gmane.org with esmtp (Exim 4.69) (envelope-from ) id 1ZhyfD-0000Mw-SD for guile-devel@m.gmane.org; Fri, 02 Oct 2015 13:38:12 +0200 Original-Received: from localhost ([::1]:58801 helo=lists.gnu.org) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ZhyfD-0007XZ-46 for guile-devel@m.gmane.org; Fri, 02 Oct 2015 07:38:11 -0400 Original-Received: from eggs.gnu.org ([2001:4830:134:3::10]:50227) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ZhxZA-0003JB-Cq for guile-devel@gnu.org; Fri, 02 Oct 2015 06:27:59 -0400 Original-Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1ZhxZ2-0000vB-TZ for guile-devel@gnu.org; Fri, 02 Oct 2015 06:27:52 -0400 Original-Received: from mail-wi0-x22c.google.com ([2a00:1450:400c:c05::22c]:38866) by eggs.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1ZhxZ2-0000v5-8X for guile-devel@gnu.org; Fri, 02 Oct 2015 06:27:44 -0400 Original-Received: by wiclk2 with SMTP id lk2so24973601wic.1 for ; Fri, 02 Oct 2015 03:27:43 -0700 (PDT) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=gmail.com; s=20120113; h=from:to:subject:references:date:in-reply-to:message-id:user-agent :mime-version:content-type; bh=G84KHDed1oWbI4fVUT/kWEQehaQSFrVOZtqAO/gN1gQ=; b=r3wFKkn9Wd47FwoJ9hVWhUWiwCZMjva1gMHqcvLtxJb6hyPcfFu+98Vwu8fRX6QX+r M3h6HlAzACYz0dC7s9BGmB/EUtZQAaS/2+UQfhS0XfYxQ/+ni1VHgYVy3d2vqBK7LVNI XgoZJcgov3bN8HcCpQ2EfUk1g/Sbzn6OPtGyuseUcuQelzi8t5jv7YgaGa7yc0AHOrSi r2AibX8sBlnWPb78ThGzxxgSIeQHxm//C12VDeCqwRb5X676fT9cHgk7Ba809ybpDUdQ un9j9Dpwsis8350E9NGZLN1fIno414TmHIKxJhF5R+fJM+eEx+jogdO4j1qWtFlDYu7G eMhw== X-Received: by 10.180.39.193 with SMTP id r1mr3330654wik.57.1443781663584; Fri, 02 Oct 2015 03:27:43 -0700 (PDT) Original-Received: from T420.taylan ([2a02:908:c32:4740:221:ccff:fe66:68f0]) by smtp.gmail.com with ESMTPSA id bh5sm10589976wjb.42.2015.10.02.03.27.40 for (version=TLSv1.2 cipher=ECDHE-RSA-AES128-GCM-SHA256 bits=128/128); Fri, 02 Oct 2015 03:27:41 -0700 (PDT) In-Reply-To: <87mvwet7jl.fsf@T420.taylan> ("Taylan Ulrich \=\?utf-8\?Q\?\=5C\=22Bay\=C4\=B1rl\=C4\=B1\=2FKammer\=5C\=22\=22's\?\= message of "Wed, 23 Sep 2015 00:26:22 +0200") User-Agent: Gnus/5.13 (Gnus v5.13) Emacs/24.5 (gnu/linux) X-detected-operating-system: by eggs.gnu.org: Error: Malformed IPv6 address (bad octet value). X-Received-From: 2a00:1450:400c:c05::22c X-BeenThere: guile-devel@gnu.org X-Mailman-Version: 2.1.14 Precedence: list List-Id: "Developers list for Guile, the GNU extensibility library" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Original-Sender: guile-devel-bounces+guile-devel=m.gmane.org@gnu.org Xref: news.gmane.org gmane.lisp.guile.devel:17886 Archived-At: --=-=-= Content-Type: text/plain Here's another update. (As always, tell me if you need it as a patch against another version I sent to the ML.) Summary: The log file name is now *.srfi64.log to make surer that no file gets accidentally overwritten. The output format is also made more readable. Other changes are mostly minor cleanup of architecture, and fixes for Kawa and Larceny that don't concern Guile. --=-=-= Content-Type: text/x-diff; charset=utf-8 Content-Disposition: inline; filename=0001-Switch-to-modernized-SRFI-64-implementation.patch Content-Transfer-Encoding: quoted-printable >From c880143ecfbf715ec320ef623e91a421d8a53503 Mon Sep 17 00:00:00 2001 From: =3D?UTF-8?q?Taylan=3D20Ulrich=3D20Bay=3DC4=3DB1rl=3DC4=3DB1/Kammer?=3D Date: Tue, 1 Sep 2015 22:57:09 +0200 Subject: [PATCH 1/2] Switch to modernized 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 | 14 +- module/srfi/srfi-64/execution.body.scm | 426 ++++++++++ module/srfi/srfi-64/source-info.body.scm | 88 ++ module/srfi/srfi-64/test-runner-simple.body.scm | 168 ++++ module/srfi/srfi-64/test-runner.body.scm | 165 ++++ module/srfi/srfi-64/testing.scm | 1040 -------------------= ---- 7 files changed, 868 insertions(+), 1044 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 7e96de7..178c6f1 100644 --- a/module/Makefile.am +++ b/module/Makefile.am @@ -258,7 +258,11 @@ ICE_9_SOURCES =3D \ ice-9/local-eval.scm \ ice-9/unicode.scm =20 -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 =20 SRFI_SOURCES =3D \ srfi/srfi-2.scm \ @@ -400,7 +404,10 @@ NOCOMP_SOURCES =3D \ ice-9/r6rs-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 81dcc5d..e6c6ce8 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 @@ -52,4 +52,14 @@ =20 (cond-expand-provide (current-module) '(srfi-64)) =20 -(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/e= xecution.body.scm new file mode 100644 index 0000000..717d74b --- /dev/null +++ b/module/srfi/srfi-64/execution.body.scm @@ -0,0 +1,426 @@ +;; 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 =C3=81lvaro Castro-Castilla, Copyright (= c) 2012. +;; Support for Guile 2 by Mark H Weaver , Copyright (c) 20= 14. +;; Refactored by Taylan Ulrich Bay=C4=B1rl=C4=B1/Kammer, Copyright (c) 201= 4, 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-expa= nd +;;; phase (which makes compile times suffer and may hit code size limits i= n 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 ((runner (test-runner-simple)) + (log-file (string-append suite-name ".srfi64.log"))) + (%test-runner-log-file! runner log-file) + (test-runner-current runner)))) + +(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 (=3D 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))))))) + +(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 (>=3D 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-eff= ects; +;;; no early returning or and/or short-circuiting of procedure calls allow= ed. + +(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 runn= er)))) + ((xfail) + (test-runner-xfail-count! runner (+ 1 (test-runner-xfail-count runn= er)))) + ((skip) + (test-runner-skip-count! runner (+ 1 (test-runner-skip-count runner= ))))) + (%test-runner-total-count! runner (+ 1 (%test-runner-total-count runne= r))) + ((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 import= ant +;;; 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=3D margin) + (lambda (value expected) + (let ((rval (real-part value)) + (ival (imag-part value)) + (rexp (real-part expected)) + (iexp (imag-part expected))) + (and (>=3D rval (- rexp margin)) + (>=3D ival (- iexp margin)) + (<=3D rval (+ rexp margin)) + (<=3D 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=3D ) )))) + +(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))) + (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 0000000..6848735 --- /dev/null +++ b/module/srfi/srfi-64/source-info.body.scm @@ -0,0 +1,88 @@ +;; Copyright (c) 2015 Taylan Ulrich Bay=C4=B1rl=C4=B1/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 o= f 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 it= s real +;;; position, which is within the body of a syntax-rules macro like test-a= ssert, +;;; 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 0000000..f7ce2e3 --- /dev/null +++ b/module/srfi/srfi-64/test-runner-simple.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 =C3=81lvaro Castro-Castilla, Copyright (= c) 2012. +;; Support for Guile 2 by Mark H Weaver , Copyright (c) 20= 14. +;; Refactored by Taylan Ulrich Bay=C4=B1rl=C4=B1/Kammer, Copyright (c) 201= 4, 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=3D? #\newline c) #\space c)) + (let* ((string (string-map newline->space string)) + (fill "...") + (fill-len (string-length fill)) + (string-len (string-length string))) + (if (<=3D 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) + (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) + 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 (=3D 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=3D? "" 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 0000000..f8131eb --- /dev/null +++ b/module/srfi/srfi-64/test-runner.body.scm @@ -0,0 +1,165 @@ +;; 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 =C3=81lvaro Castro-Castilla, Copyright (= c) 2012. +;; Support for Guile 2 by Mark H Weaver , Copyright (c) 20= 14. +;; Refactored by Taylan Ulrich Bay=C4=B1rl=C4=B1/Kammer, Copyright (c) 201= 4, 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 a= nd + ;; test-end forms in the execution library. They're called at the + ;; beginning/end of each individual test, whereas the test-begin and tes= t-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!) + + (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-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 d686662..0000000 --- a/module/srfi/srfi-64/testing.scm +++ /dev/null @@ -1,1040 +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 =C3=81lvaro Castro-Castilla, Copyright (= c) 2012. -;; Support for Guile 2 by Mark H Weaver , Copyright (c) 20= 14. -;; -;; 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-defin= e: - 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=3Dend doesn't match test-begin. - (on-bad-end-name 18 test-runner-on-bad-end-name test-runner-on-bad-end-na= me!) - ;; Cumulate count of all tests that have been done. - (total-count 19 %test-runner-total-count %test-runner-total-count!) - ;; Stack (list) of (count-at-start . expected-count): - (count-list 20 %test-runner-count-list %test-runner-count-list!) - (result-alist 21 test-result-alist test-result-alist!) - ;; Field can be used by test-runner for any purpose. - ;; test-runner-simple uses it for a log file. - (aux-value 22 test-runner-aux-value test-runner-aux-value!) -) - -(define (test-runner-reset runner) - (test-result-alist! runner '()) - (test-runner-pass-count! runner 0) - (test-runner-fail-count! runner 0) - (test-runner-xpass-count! runner 0) - (test-runner-xfail-count! runner 0) - (test-runner-skip-count! runner 0) - (%test-runner-total-count! runner 0) - (%test-runner-count-list! runner '()) - (%test-runner-run-list! runner #t) - (%test-runner-skip-list! runner '()) - (%test-runner-fail-list! runner '()) - (%test-runner-skip-save! runner '()) - (%test-runner-fail-save! runner '()) - (test-runner-group-stack! runner '())) - -(define (test-runner-group-path runner) - (reverse (test-runner-group-stack runner))) - -(define (%test-null-callback runner) #f) - -(define (test-runner-null) - (let ((runner (%test-runner-alloc))) - (test-runner-reset runner) - (test-runner-on-group-begin! runner (lambda (runner name count) #f)) - (test-runner-on-group-end! runner %test-null-callback) - (test-runner-on-final! runner %test-null-callback) - (test-runner-on-test-begin! runner %test-null-callback) - (test-runner-on-test-end! runner %test-null-callback) - (test-runner-on-bad-count! runner (lambda (runner count expected) #f)) - (test-runner-on-bad-end-name! runner (lambda (runner begin end) #f)) - runner)) - -;; Not part of the specification. FIXME -;; Controls whether a log file is generated. -(define test-log-to-file #t) - -(define (test-runner-simple) - (let ((runner (%test-runner-alloc))) - (test-runner-reset runner) - (test-runner-on-group-begin! runner test-on-group-begin-simple) - (test-runner-on-group-end! runner test-on-group-end-simple) - (test-runner-on-final! runner test-on-final-simple) - (test-runner-on-test-begin! runner test-on-test-begin-simple) - (test-runner-on-test-end! runner test-on-test-end-simple) - (test-runner-on-bad-count! runner test-on-bad-count-simple) - (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple) - runner)) - -(cond-expand - (srfi-39 - (define test-runner-current (make-parameter #f)) - (define test-runner-factory (make-parameter test-runner-simple))) - (else - (define %test-runner-current #f) - (define-syntax test-runner-current - (syntax-rules () - ((test-runner-current) - %test-runner-current) - ((test-runner-current runner) - (set! %test-runner-current runner)))) - (define %test-runner-factory test-runner-simple) - (define-syntax test-runner-factory - (syntax-rules () - ((test-runner-factory) - %test-runner-factory) - ((test-runner-factory runner) - (set! %test-runner-factory runner)))))) - -;; A safer wrapper to test-runner-current. -(define (test-runner-get) - (let ((r (test-runner-current))) - (if (not r) - (cond-expand - (srfi-23 (error "test-runner not initialized - test-begin missing?")) - (else #t))) - r)) - -(define (%test-specifier-matches spec runner) - (spec runner)) - -(define (test-runner-create) - ((test-runner-factory))) - -(define (%test-any-specifier-matches list runner) - (let ((result #f)) - (let loop ((l list)) - (cond ((null? l) result) - (else - (if (%test-specifier-matches (car l) runner) - (set! result #t)) - (loop (cdr l))))))) - -;; Returns #f, #t, or 'xfail. -(define (%test-should-execute runner) - (let ((run (%test-runner-run-list runner))) - (cond ((or - (not (or (eqv? run #t) - (%test-any-specifier-matches run runner))) - (%test-any-specifier-matches - (%test-runner-skip-list runner) - runner)) - (test-result-set! runner 'result-kind 'skip) - #f) - ((%test-any-specifier-matches - (%test-runner-fail-list runner) - runner) - (test-result-set! runner 'result-kind 'xfail) - 'xfail) - (else #t)))) - -(define (%test-begin suite-name count) - (if (not (test-runner-current)) - (test-runner-current (test-runner-create))) - (let ((runner (test-runner-current))) - ((test-runner-on-group-begin runner) runner suite-name count) - (%test-runner-skip-save! runner - (cons (%test-runner-skip-list runner) - (%test-runner-skip-save runner))) - (%test-runner-fail-save! runner - (cons (%test-runner-fail-list runner) - (%test-runner-fail-save runner))) - (%test-runner-count-list! runner - (cons (cons (%test-runner-total-count runner) - count) - (%test-runner-count-list runner))) - (test-runner-group-stack! runner (cons suite-name - (test-runner-group-stack runner))))) -(cond-expand - (kawa - ;; Kawa has test-begin built in, implemented as: - ;; (begin - ;; (cond-expand (srfi-64 #!void) (else (require 'srfi-64))) - ;; (%test-begin suite-name [count])) - ;; This puts test-begin but only test-begin in the default environment., - ;; which makes normal test suites loadable without non-portable commands. - ) - (else - (define-syntax test-begin - (syntax-rules () - ((test-begin suite-name) - (%test-begin suite-name #f)) - ((test-begin suite-name count) - (%test-begin suite-name count)))))) - -(define (test-on-group-begin-simple runner suite-name count) - (if (null? (test-runner-group-stack runner)) - (begin - (display "%%%% Starting test ") - (display suite-name) - (if test-log-to-file - (let* ((log-file-name - (if (string? test-log-to-file) test-log-to-file - (string-append suite-name ".log"))) - (log-file - (cond-expand (mzscheme - (open-output-file log-file-name 'truncate/replace)) - (else (open-output-file log-file-name))))) - (display "%%%% Starting test " log-file) - (display suite-name log-file) - (newline log-file) - (test-runner-aux-value! runner log-file) - (display " (Writing full log to \"") - (display log-file-name) - (display "\")"))) - (newline))) - (let ((log (test-runner-aux-value runner))) - (if (output-port? log) - (begin - (display "Group begin: " log) - (display suite-name log) - (newline log)))) - #f) - -(define (test-on-group-end-simple runner) - (let ((log (test-runner-aux-value runner))) - (if (output-port? log) - (begin - (display "Group end: " log) - (display (car (test-runner-group-stack runner)) log) - (newline log)))) - #f) - -(define (%test-on-bad-count-write runner count expected-count port) - (display "*** Total number of tests was " port) - (display count port) - (display " but should be " port) - (display expected-count port) - (display ". ***" port) - (newline port) - (display "*** Discrepancy indicates testsuite error or exceptions. ***" = port) - (newline port)) - -(define (test-on-bad-count-simple runner count expected-count) - (%test-on-bad-count-write runner count expected-count (current-output-po= rt)) - (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-n= ame - " does not match test-begin " end-name))) - (cond-expand - (srfi-23 (error msg)) - (else (display msg) (newline))))) -=20=20 - -(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 (=3D 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))))) -=09=20=20=20=20 -(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=3D error) - (lambda (value expected) - (let ((rval (real-part value)) - (ival (imag-part value)) - (rexp (real-part expected)) - (iexp (imag-part expected))) - (and (>=3D rval (- rexp error)) - (>=3D ival (- iexp error)) - (<=3D rval (+ rexp error)) - (<=3D 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=3D error) expected expr)))) - (((mac expected expr error) line) - (syntax - (let* ((r (test-runner-get))) - (test-result-alist! r line) - (%test-comp2body r (%test-approximate=3D 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=3D error) tname expected expr)) - ((test-approximate expected expr error) - (%test-comp2 (%test-approximate=3D 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 e= xpr) - #f) - (lambda (key . args) - ;; TODO: decide how to specify expe= cted - ;; 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 (>=3D 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)))))))) -=20=20 -(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)))))))) -=20=20 -(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"))))) - --=20 2.5.0 --=-=-=--