summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2012-02-24 19:58:45 +0100
committerAndy Wingo <wingo@pobox.com>2012-02-24 19:58:45 +0100
commit006163e02febaf5569bd42b362957a99c01c4528 (patch)
tree6d0fd0ee50b209a1449e8583eab0aaf365557767
parenta2e946f1ef83cd1fd8c87412cc49f6c6d1e0ac61 (diff)
downloadguile-006163e02febaf5569bd42b362957a99c01c4528.tar.gz
slight cleanup to run-test
* test-suite/lib.scm (run-test): Slight cleanup.
-rw-r--r--test-suite/lib.scm55
1 files changed, 27 insertions, 28 deletions
diff --git a/test-suite/lib.scm b/test-suite/lib.scm
index 681a0d158..5785378ad 100644
--- a/test-suite/lib.scm
+++ b/test-suite/lib.scm
@@ -314,34 +314,33 @@
;;; The central testing routine.
;;; The idea is taken from Greg, the GNUstep regression test environment.
-(define run-test #f)
-(let ((test-running #f))
- (define (local-run-test 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)
- (report (if expect-pass 'fail 'xfail) test-name))
- ((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))))
- (set! run-test local-run-test))
+(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)
+ (report (if expect-pass 'fail 'xfail) test-name))
+ ((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)))))
;;; A short form for tests that are expected to pass, taken from Greg.
(define-syntax pass-if