suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Removed the redundant uncaught-exception-handler setting, use with-handlers except for the mzscheme tests

Browse Source 
svn: r11755
This commit is contained in:
Eli Barzilay 2008-09-15 09:57:16 +00:00
parent d32f0a9692
commit 99dc711ac0
1 changed files with 13 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
collects/tests/run-automated-tests.ss
View File

@ -27,9 +27,11 @@
;; Each should be a list with a mode symbol (`load' or `require'),
;; the path to the test file (relative to this script) and module
;; specifications for things to require into the initial namespace
;; for the test before the test is loaded.
;; for the test before the test is loaded. ('no-handler is a
;; special flag that means that errors raised by the test suite are
;; ignored, and should only be used by the mzscheme tests.)
(define tests
'([load "mzscheme/quiet.ss" (lib "scheme/init")]
'([no-handler load "mzscheme/quiet.ss" (lib "scheme/init")]
[require "typed-scheme/main.ss"]
[require "match/plt-match-tests.ss"]
;; [require "stepper/automatic-tests.ss" (lib "scheme/base")]
@ -44,11 +46,11 @@
(define exit-code 0)
(for ([t tests])
(define no-handler? (and (eq? 'no-handler (car t)) (set! t (cdr t))))
(define name (cadr t))
(define stderr (current-error-port))
(define (echo fmt . args)
(fprintf stderr "*** ~a: ~a\n" name (apply format fmt args)))
(define orig-exn-handler (uncaught-exception-handler))
(newline stderr)
(echo "running...")
(let/ec break
@ -62,15 +64,16 @@
(lambda () (sleep 900) (echo "Timeout!") (break-thread th))))
(parameterize* ([exit-handler
(lambda (n) (abort n "exit with error code ~a" n))]
[uncaught-exception-handler
(lambda (exn)
(if (eq? orig-exn-handler (uncaught-exception-handler))
(abort 1 "error: ~a" (exn-message exn))
(orig-exn-handler exn)))]
[current-namespace (make-base-empty-namespace)])
(for-each namespace-require (cddr t))
((case (car t) [(load) load] [(require) namespace-require])
(build-path here name))
(let ([thunk (lambda ()
((case (car t) [(load) load] [(require) namespace-require])
(build-path here name)))])
(if no-handler?
(thunk)
(with-handlers ([void (lambda (exn)
(abort 1 "error: ~a" (exn-message exn)))])
(thunk))))
(echo "all tests passed."))))
(exit exit-code)