mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 22:10:21 +02:00
Code Activity

slight cleanup to run-test

Browse source 
* test-suite/lib.scm (run-test): Slight cleanup.
This commit is contained in:
Andy Wingo 2012-02-24 19:58:45 +01:00
parent a2e946f1ef
commit 006163e02f
1 changed files with 27 additions and 28 deletions
Download patch file Download diff file Expand all files Collapse all files

55
test-suite/lib.scm
View file

@ -314,34 +314,33 @@
;;; The central testing routine. ;;; The central testing routine.
;;; The idea is taken from Greg, the GNUstep regression test environment. ;;; The idea is taken from Greg, the GNUstep regression test environment.
(define run-test #f) (define run-test
(let ((test-running #f)) (let ((test-running #f))
(define (local-run-test name expect-pass thunk) (lambda (name expect-pass thunk)
(if test-running (if test-running
(error "Nested calls to run-test are not permitted.") (error "Nested calls to run-test are not permitted."))
(let ((test-name (full-name name))) (let ((test-name (full-name name)))
(set! test-running #t) (set! test-running #t)
(catch #t (catch #t
(lambda () (lambda ()
(let ((result (thunk))) (let ((result (thunk)))
(if (eq? result #t) (throw 'pass)) (if (eq? result #t) (throw 'pass))
(if (eq? result #f) (throw 'fail)) (if (eq? result #f) (throw 'fail))
(throw 'unresolved))) (throw 'unresolved)))
(lambda (key . args) (lambda (key . args)
(case key (case key
((pass) ((pass)
(report (if expect-pass 'pass 'upass) test-name)) (report (if expect-pass 'pass 'upass) test-name))
((fail) ((fail)
(report (if expect-pass 'fail 'xfail) test-name)) (report (if expect-pass 'fail 'xfail) test-name))
((unresolved untested unsupported) ((unresolved untested unsupported)
(report key test-name)) (report key test-name))
((quit) ((quit)
(report 'unresolved test-name) (report 'unresolved test-name)
(quit)) (quit))
(else (else
(report 'error test-name (cons key args)))))) (report 'error test-name (cons key args))))))
(set! test-running #f)))) (set! test-running #f)))))
(set! run-test local-run-test))
;;; A short form for tests that are expected to pass, taken from Greg. ;;; A short form for tests that are expected to pass, taken from Greg.
(define-syntax pass-if (define-syntax pass-if