* Testing with Custom Evaluators
@ 2013-06-15 3:53 Noah Lavine
0 siblings, 0 replies; only message in thread
From: Noah Lavine @ 2013-06-15 3:53 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1.1: Type: text/plain, Size: 389 bytes --]
Hello,
Apologies for not Guiling in a while! I just finished up a patch I was
talking about a while ago. It lets you run the test suite with a custom
evaluator. This is useful if you're testing new evaluators (or compilers!).
Along the way, I also added the ability for the test suite to test itself,
so I could make sure the custom evaluator stuff works.
What do you think?
Best,
Noah
[-- Attachment #1.2: Type: text/html, Size: 492 bytes --]
[-- Attachment #2: 0001-Testing-with-Custom-Evaluators.patch --]
[-- Type: application/octet-stream, Size: 14614 bytes --]
From a24ce10b5336316a348a47f1f562810b43247929 Mon Sep 17 00:00:00 2001
From: Noah Lavine <noah.b.lavine@gmail.com>
Date: Fri, 14 Jun 2013 23:43:59 -0400
Subject: [PATCH] Testing with Custom Evaluators
* test-suite/test-suite/lib.scm: add support for testing with custom
evaluators, and for testing the test suite itself.
* test-suite/testse/test-test.test: test the test suite.
* test-suite/guile-test: accept a new command-line argument giving the
testing evaluator.
---
test-suite/guile-test | 42 +++++++-----
test-suite/test-suite/lib.scm | 140 ++++++++++++++++++++++++++--------------
test-suite/tests/test-test.test | 86 ++++++++++++++++++++++++
3 files changed, 204 insertions(+), 64 deletions(-)
create mode 100755 test-suite/tests/test-test.test
diff --git a/test-suite/guile-test b/test-suite/guile-test
index cdcfe49..7bc2bb4 100755
--- a/test-suite/guile-test
+++ b/test-suite/guile-test
@@ -184,7 +184,9 @@
(coverage
(single-char #\c))
(debug
- (single-char #\d))))))
+ (single-char #\d))
+ (evaluator
+ (value #t))))))
(define (opt tag default)
(let ((pair (assq tag options)))
(if pair (cdr pair) default)))
@@ -234,21 +236,29 @@
((fail upass error)
(set! global-pass #f)))))
- ;; Run the tests.
- (let ((run-tests
- (lambda ()
- (for-each (lambda (test)
- (display (string-append "Running " test "\n"))
- (with-test-prefix test
- (load (test-file-name test))))
- tests))))
- (if (opt 'coverage #f)
- (let-values (((coverage-data _)
- (with-code-coverage (the-vm) run-tests)))
- (let ((out (open-output-file "guile.info")))
- (coverage-data->lcov coverage-data out)
- (close out)))
- (run-tests)))
+ ;; Set the testing evaluator if we were passed --evaluator
+ (parameterize
+ ((testing-evaluator
+ (let ((val (opt 'evaluator #f)))
+ (if val (eval (read (open-input-string val))
+ (interaction-environment))
+ (testing-evaluator)))))
+
+ ;; Run the tests.
+ (let ((run-tests
+ (lambda ()
+ (for-each (lambda (test)
+ (display (string-append "Running " test "\n"))
+ (with-test-prefix test
+ (load (test-file-name test))))
+ tests))))
+ (if (opt 'coverage #f)
+ (let-values (((coverage-data _)
+ (with-code-coverage (the-vm) run-tests)))
+ (let ((out (open-output-file "guile.info")))
+ (coverage-data->lcov coverage-data out)
+ (close out)))
+ (run-tests))))
;; Display the final counts, both to the user and in the log
;; file.
diff --git a/test-suite/test-suite/lib.scm b/test-suite/test-suite/lib.scm
index e25df78..a2f84e6 100644
--- a/test-suite/test-suite/lib.scm
+++ b/test-suite/test-suite/lib.scm
@@ -43,10 +43,14 @@
;; Reporting passes and failures.
run-test
+ run-test-from-source
pass-if expect-fail
pass-if-equal
pass-if-exception expect-fail-exception
+ ;; Using custom evaluators
+ testing-evaluator test-with-testing-evaluator
+
;; Naming groups of tests in a regular fashion.
with-test-prefix
with-test-prefix*
@@ -68,7 +72,8 @@
make-count-reporter print-counts
make-log-reporter
full-reporter
- user-reporter))
+ user-reporter
+ with-only-reporters))
;;;; If you're using Emacs's Scheme mode:
@@ -130,6 +135,21 @@
;;;; exception is thrown, the test fails expectedly. If some other
;;;; exception is thrown, it is an error.
+;;;; The test suite can also be used to test new interpreters or
+;;;; compilers. For this to work, the test suite needs access to the
+;;;; source code of the function in question, not just a thunk. That can
+;;;; be done with the function (run-test-from-source name
+;;;; expected-result exp #:evaluator eval). It has the same interface as
+;;;; run-test, but executes the Scheme expression exp by passing it to
+;;;; the given evalutor (the default uses the standard `eval' in the
+;;;; interaction-environment).
+
+;;;; For even more convenience, users can set the parameter
+;;;; `testing-evaluator' to any function they would like that takes an
+;;;; S-expression and returns a value, and then declare their tests with
+;;;; the macro `test-with-testing-evaluator'.
+
+
\f
;;;; TEST NAMES
;;;;
@@ -315,37 +335,46 @@
;;; The central testing routine.
;;; The idea is taken from Greg, the GNUstep regression test environment.
-(define run-test
- (let ((test-running #f))
- (lambda (name expect-pass thunk)
- (if test-running
- (error "Nested calls to run-test are not permitted."))
- (let ((test-name (full-name name)))
- (set! test-running #t)
- (catch #t
- (lambda ()
- (let ((result (thunk)))
- (if (eq? result #t) (throw 'pass))
- (if (eq? result #f) (throw 'fail))
- (throw 'unresolved)))
- (lambda (key . args)
- (case key
- ((pass)
- (report (if expect-pass 'pass 'upass) test-name))
- ((fail)
- ;; ARGS may contain extra info about the failure,
- ;; such as the expected and actual value.
- (apply report (if expect-pass 'fail 'xfail)
- test-name
- args))
- ((unresolved untested unsupported)
- (report key test-name))
- ((quit)
- (report 'unresolved test-name)
- (quit))
- (else
- (report 'error test-name (cons key args))))))
- (set! test-running #f)))))
+(define (run-test name expect-pass thunk)
+ (let ((test-name (full-name name)))
+ (catch #t
+ (lambda ()
+ (let ((result (thunk)))
+ (if (eq? result #t) (throw 'pass))
+ (if (eq? result #f) (throw 'fail))
+ (throw 'unresolved)))
+ (lambda (key . args)
+ (case key
+ ((pass)
+ (report (if expect-pass 'pass 'upass) test-name))
+ ((fail)
+ ;; ARGS may contain extra info about the failure, such
+ ;; as the expected and actual value.
+ (apply report (if expect-pass 'fail 'xfail)
+ test-name
+ args))
+ ((unresolved untested unsupported)
+ (report key test-name))
+ ((quit)
+ (report 'unresolved test-name)
+ (quit))
+ (else
+ (report 'error test-name (cons key args))))))))
+
+(define (default-eval exp)
+ (eval exp (interaction-environment)))
+
+(define* (run-test-from-source name expect-pass exp
+ #:key (evaluator default-eval))
+ (run-test name expect-pass
+ (lambda ()
+ (evaluator exp))))
+
+(define testing-evaluator (make-parameter default-eval))
+
+(define-syntax-rule (test-with-testing-evaluator name expect-pass exp)
+ (run-test-from-source name expect-pass 'exp
+ #:evaluator (testing-evaluator)))
;;; A short form for tests that are expected to pass, taken from Greg.
(define-syntax pass-if
@@ -353,9 +382,9 @@
((_ name)
;; presume this is a simple test, i.e. (pass-if (even? 2))
;; where the body should also be the name.
- (run-test 'name #t (lambda () name)))
+ (test-with-testing-evaluator 'name #t name))
((_ name rest ...)
- (run-test name #t (lambda () rest ...)))))
+ (test-with-testing-evaluator name #t (begin rest ...)))))
(define-syntax pass-if-equal
(syntax-rules ()
@@ -363,13 +392,12 @@
((_ expected body)
(pass-if-equal 'body expected body))
((_ name expected body ...)
- (run-test name #t
- (lambda ()
- (let ((result (begin body ...)))
- (or (equal? expected result)
- (throw 'fail
- 'expected-value expected
- 'actual-value result))))))))
+ (test-with-testing-evaluator name #t
+ (let ((result (begin body ...)))
+ (or (equal? expected result)
+ (throw 'fail
+ 'expected-value expected
+ 'actual-value result)))))))
;;; A short form for tests that are expected to fail, taken from Greg.
(define-syntax expect-fail
@@ -377,16 +405,16 @@
((_ name)
;; presume this is a simple test, i.e. (expect-fail (even? 2))
;; where the body should also be the name.
- (run-test 'name #f (lambda () name)))
+ (test-with-testing-evaluator 'name #f name))
((_ name rest ...)
- (run-test name #f (lambda () rest ...)))))
+ (test-with-testing-evaluator name #f (begin rest ...)))))
;;; A helper function to implement the macros that test for exceptions.
-(define (run-test-exception name exception expect-pass thunk)
+(define (run-test-exception name exception expect-pass exp)
(run-test name expect-pass
(lambda ()
(stack-catch (car exception)
- (lambda () (thunk) #f)
+ (lambda () ((testing-evaluator) exp) #f)
(lambda (key proc message . rest)
(cond
;; handle explicit key
@@ -414,13 +442,13 @@
(define-syntax pass-if-exception
(syntax-rules ()
((_ name exception body rest ...)
- (run-test-exception name exception #t (lambda () body rest ...)))))
+ (run-test-exception name exception #t '(begin body rest ...)))))
;;; A short form for tests expected to fail to throw a certain exception.
(define-syntax expect-fail-exception
(syntax-rules ()
((_ name exception body rest ...)
- (run-test-exception name exception #f (lambda () body rest ...)))))
+ (run-test-exception name exception #f '(begin body rest ...)))))
\f
;;;; TEST NAMES
@@ -581,6 +609,21 @@
;;; The default reporter, to be used only if no others exist.
(define default-reporter #f)
+;;; For running a test in an environment with no outside reporters,
+;;; even the default one. This lets the test suite test itself.
+
+(define use-default-reporter #t)
+(define-syntax-rule (with-only-reporters (rep0 ...) body0 ...)
+ (let ((old-reporters reporters)
+ (old-use-default use-default-reporter)
+ (new-reporters (list rep0 ...)))
+ (dynamic-wind
+ (lambda () (set! reporters new-reporters)
+ (set! use-default-reporter #f))
+ (lambda () body0 ...)
+ (lambda () (set! reporters old-reporters)
+ (set! use-default-reporter old-use-default)))))
+
;;; Add the procedure REPORTER to the current set of reporter functions.
;;; Signal an error if that reporter procedure object is already registered.
(define (register-reporter reporter)
@@ -604,7 +647,8 @@
(if (pair? reporters)
(for-each (lambda (reporter) (apply reporter args))
reporters)
- (apply default-reporter args)))
+ (if use-default-reporter
+ (apply default-reporter args))))
\f
;;;; Some useful standard reporters:
diff --git a/test-suite/tests/test-test.test b/test-suite/tests/test-test.test
new file mode 100755
index 0000000..8ebccb9
--- /dev/null
+++ b/test-suite/tests/test-test.test
@@ -0,0 +1,86 @@
+;;;; test-test.test -*- mode: scheme; coding: utf-8; -*-
+;;;;
+;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;;
+;;;; This library is free software; you can redistribute it and/or
+;;;; modify it under the terms of the GNU Lesser General Public
+;;;; License as published by the Free Software Foundation; either
+;;;; version 3 of the License, or (at your option) any later version.
+;;;;
+;;;; This library is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;;; Lesser General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU Lesser General Public
+;;;; License along with this library; if not, write to the Free Software
+;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; This module tests the test suite itself.
+
+(define-module (test-test)
+ #:use-module (test-suite lib))
+
+;; here is the infrastructure for testing the test suite
+
+(define test-passed #f)
+
+(define (reporter result name . args)
+ (set! test-passed
+ (if (memv result '(pass xfail)) #t #f)))
+
+(define-syntax-rule (recursive-test name body0 ...)
+ (pass-if name
+ (with-only-reporters (reporter)
+ body0 ...)
+ test-passed))
+
+;; if using emacs:
+;; (put 'recursive-test 'scheme-indent-function 1)
+
+;; and here are the tests themselves
+
+(recursive-test "run-test #t"
+ (run-test "inner test" #t (lambda () #t)))
+
+(recursive-test "run-test #f"
+ (run-test "inner test" #f (lambda () #f)))
+
+(recursive-test "run-test-from-source #t"
+ (run-test-from-source "basic source test #t" #t #t))
+
+(recursive-test "run-test-from-source #f"
+ (run-test-from-source "basic source test #f" #f #f))
+
+(recursive-test "run-test-from-source custom evaluator"
+ (run-test-from-source "custom evaluator" #t #f
+ #:evaluator (lambda (exp) #t)))
+
+(parameterize ((testing-evaluator
+ (lambda (exp) #t)))
+ (recursive-test "test-with-testing-evaluator"
+ (test-with-testing-evaluator "test-with-testing-evaluator" #t #f)))
+
+(recursive-test "pass-if"
+ (pass-if "pass-if" #t))
+
+(recursive-test "pass-if-equal"
+ (pass-if-equal "pass-if-equal" 3 (+ 1 2)))
+
+(recursive-test "expect-fail"
+ (expect-fail "expect-fail" #f))
+
+(recursive-test "run-test-exception"
+ ((@@ (test-suite lib) run-test-exception)
+ "run-test-exception" exception:miscellaneous-error #t
+ '(error "A fake error!")))
+
+(recursive-test "pass-if-exception"
+ (pass-if-exception "pass-if-exception"
+ exception:miscellaneous-error
+ (error "A fake error!")))
+
+(recursive-test "expect-fail-exception"
+ (expect-fail-exception "expect-fail-exception"
+ exception:miscellaneous-error
+ #t))
--
1.8.1.2
^ permalink raw reply related [flat|nested] only message in thread
only message in thread, other threads:[~2013-06-15 3:53 UTC | newest]
Thread overview: (only message) (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2013-06-15 3:53 Testing with Custom Evaluators Noah Lavine
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).