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

raco test: handling of spurious files

Browse Source 
A `--drdr` run shouldn't stop because a discoevered file
disappears (such as one generated temporarily by a test).

Also, use new style for some errors.

original commit: 034acfa514
This commit is contained in:
Matthew Flatt 2014-06-16 14:59:09 +01:00
parent eba91e16bd
commit 52ac9d616e
1 changed files with 30 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -48,6 +48,8 @@
n)) n))
(* 4 60 60))) ; default: wait at most 4 hours (* 4 60 60))) ; default: wait at most 4 hours
(define test-exe-name (string->symbol (short-program+command-name)))
;; Stub for running a test in a process: ;; Stub for running a test in a process:
(module process racket/base (module process racket/base
(require rackunit/log (require rackunit/log
@ -169,9 +171,9 @@
(set! done? #t))))) (set! done? #t)))))
(unless (thread? (sync/timeout timeout t)) (unless (thread? (sync/timeout timeout t))
(set! timeout? #t) (set! timeout? #t)
(error 'test "timeout after ~a seconds" timeout)) (error test-exe-name "timeout after ~a seconds" timeout))
(unless done? (unless done?
(error 'test "test raised an exception")) (error test-exe-name "test raised an exception"))
(define post (test-log #:display? #f #:exit? #f)) (define post (test-log #:display? #f #:exit? #f))
(values 0 (values 0
(cons (- (car post) (car pre)) (cons (- (car post) (car pre))
@ -192,7 +194,7 @@
;; Wait for the place to finish: ;; Wait for the place to finish:
(unless (sync/timeout timeout (place-dead-evt pl)) (unless (sync/timeout timeout (place-dead-evt pl))
(set! timeout? #t) (set! timeout? #t)
(error 'test "timeout after ~a seconds" timeout)) (error test-exe-name "timeout after ~a seconds" timeout))
;; Get result code and test results: ;; Get result code and test results:
(values (place-wait pl) (values (place-wait pl)
@ -235,7 +237,7 @@
(unless (sync/timeout timeout (thread (lambda () (proc 'wait)))) (unless (sync/timeout timeout (thread (lambda () (proc 'wait))))
(set! timeout? #t) (set! timeout? #t)
(error 'test "timeout after ~a seconds" timeout)) (error test-exe-name "timeout after ~a seconds" timeout))
(define results (define results
(with-handlers ([exn:fail:read? (lambda () #f)]) (with-handlers ([exn:fail:read? (lambda () #f)])
@ -260,9 +262,9 @@
(or (equal? #"" s) (or (equal? #"" s)
(ormap (lambda (p) (regexp-match? p s)) (ormap (lambda (p) (regexp-match? p s))
ignore-stderr-patterns))) ignore-stderr-patterns)))
(error 'test "non-empty stderr: ~e" (get-output-bytes e)))) (error test-exe-name "non-empty stderr: ~e" (get-output-bytes e))))
(unless (zero? result-code) (unless (zero? result-code)
(error 'test "non-zero exit: ~e" result-code)) (error test-exe-name "non-zero exit: ~e" result-code))
(cond (cond
[test-results [test-results
(summary (car test-results) (cdr test-results) (current-label) #f 0)] (summary (car test-results) (cdr test-results) (current-label) #f 0)]
@ -276,7 +278,7 @@
(build-path lock-file-dir lock-name) (build-path lock-file-dir lock-name)
'exclusive 'exclusive
go go
(lambda () (error 'test "could not obtain lock: ~s" lock-name))) (lambda () (error test-exe-name "could not obtain lock: ~s" lock-name)))
(go)))) (go))))
;; For recording stderr while also propagating to the original stderr: ;; For recording stderr while also propagating to the original stderr:
@ -311,7 +313,7 @@
(define (add-submod mod sm) (define (add-submod mod sm)
(if (and (pair? mod) (eq? 'submod (car mod))) (if (and (pair? mod) (eq? 'submod (car mod)))
(append mod '(config)) (append mod '(config))
(error 'test "cannot add test-config submodule to path: ~s" mod))) (error test-exe-name "cannot add test-config submodule to path: ~s" mod)))
(define (dynamic-require* p d (define (dynamic-require* p d
#:id id #:id id
@ -530,8 +532,7 @@
#:sema s)) #:sema s))
(directory-list p) (directory-list p)
#:sema continue-sema)))] #:sema continue-sema)))]
[(and (file-exists? p) [(and (or (not check-suffix?)
(or (not check-suffix?)
(regexp-match rx:default-suffixes p) (regexp-match rx:default-suffixes p)
(get-cmdline p #f #:check-info? #t)) (get-cmdline p #f #:check-info? #t))
(or (not check-suffix?) (or (not check-suffix?)
@ -592,8 +593,6 @@
(list (list
(and (and run-anyways? something-wasnt-declared?) (and (and run-anyways? something-wasnt-declared?)
(test-this-module file-name #f))))))))] (test-this-module file-name #f))))))))]
[(not (file-exists? p))
(error 'test "given path ~e does not exist" p)]
[else (summary 0 0 #f null 0)])])) [else (summary 0 0 #f null 0)])]))
(module paths racket/base (module paths racket/base
@ -669,7 +668,10 @@
[collections? [collections?
(match (collection-paths e) (match (collection-paths e)
[(list) [(list)
(error 'test "Collection ~e is not installed" e)] (error test-exe-name
(string-append "collection not found\n"
" collection name: ~a")
e)]
[l [l
(with-summary (with-summary
`(collection ,e) `(collection ,e)
@ -680,7 +682,11 @@
(define p (resolved-module-path-name rmp)) (define p (resolved-module-path-name rmp))
(and (file-exists? p) p)) (and (file-exists? p) p))
(match (find (string->symbol e)) (match (find (string->symbol e))
[#f (error 'test "Library ~e does not exist" e)] [#f
(error test-exe-name
(string-append "module not found\n"
" module path: ~a")
e)]
[l [l
(with-summary (with-summary
`(library ,l) `(library ,l)
@ -691,8 +697,17 @@
(with-summary (with-summary
`(package ,e) `(package ,e)
(test-files pd #:sema continue-sema)) (test-files pd #:sema continue-sema))
(error 'test "Package ~e is not installed" e))] (error test-exe-name
(string-append "no such installed package\n"
" package name: ~a")
e))]
[else [else
(unless (or (file-exists? e)
(directory-exists? e))
(error test-exe-name
(string-append "no such file or directory\n"
" path: ~a")
e))
(test-files e (test-files e
#:check-suffix? check-suffix? #:check-suffix? check-suffix?
#:sema continue-sema)])) #:sema continue-sema)]))