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

raco test: use executable-yield-handler before exit

Browse Source 
original commit: 4a19403288
This commit is contained in:
Matthew Flatt 2013-12-29 19:05:35 -06:00
parent 65ece182a7
commit ba1038998f
1 changed files with 7 additions and 3 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
pkgs/compiler-pkgs/compiler-lib/compiler/commands/test.rkt
View File

@ -45,13 +45,15 @@
(define args (list-tail (vector->list argv) 3)) (define args (list-tail (vector->list argv) 3))
(parameterize ([current-command-line-arguments (list->vector args)]) (parameterize ([current-command-line-arguments (list->vector args)])
(dynamic-require test-module d)) (dynamic-require test-module d)
((executable-yield-handler) 0))
(call-with-output-file* (call-with-output-file*
result-file result-file
#:exists 'truncate #:exists 'truncate
(lambda (o) (lambda (o)
(write (test-log #:display? #f #:exit? #f) o)))) (write (test-log #:display? #f #:exit? #f) o)))
(exit 0))
;; Driver for running a test in a place: ;; Driver for running a test in a place:
(module place racket/base (module place racket/base
@ -64,7 +66,8 @@
(parameterize ([current-command-line-arguments (list->vector (parameterize ([current-command-line-arguments (list->vector
(cadddr l))] (cadddr l))]
[current-directory (caddr l)]) [current-directory (caddr l)])
(dynamic-require (car l) (cadr l))) (dynamic-require (car l) (cadr l))
((executable-yield-handler) 0))
;; If the tests use `rackunit`, collect result stats: ;; If the tests use `rackunit`, collect result stats:
(define test-results (define test-results
(test-log #:display? #f #:exit? #f)) (test-log #:display? #f #:exit? #f))
@ -117,6 +120,7 @@
(thread (thread
(lambda () (lambda ()
(dynamic-require p d) (dynamic-require p d)
((executable-yield-handler) 0)
(set! done? #t))))) (set! done? #t)))))
(unless (thread? (sync/timeout timeout t)) (unless (thread? (sync/timeout timeout t))
(error 'test "timeout after ~a seconds" timeout)) (error 'test "timeout after ~a seconds" timeout))