mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 05:50:26 +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 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