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

raco test: add test-command-line-arguments field for "info.rkt"

Browse Source 
Also, make `--drdr` timeout 90 seconds instead of 600.

original commit: f830768c37
This commit is contained in:
Matthew Flatt 2013-12-29 13:14:22 -06:00
parent 7ff04c1dfa
commit 65ece182a7
1 changed files with 55 additions and 29 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -42,8 +42,9 @@
(define result-file (vector-ref argv 0)) (define result-file (vector-ref argv 0))
(define test-module (read (open-input-string (vector-ref argv 1)))) (define test-module (read (open-input-string (vector-ref argv 1))))
(define d (read (open-input-string (vector-ref argv 2)))) (define d (read (open-input-string (vector-ref argv 2))))
(define args (list-tail (vector->list argv) 3))
(parameterize ([current-command-line-arguments '#()]) (parameterize ([current-command-line-arguments (list->vector args)])
(dynamic-require test-module d)) (dynamic-require test-module d))
(call-with-output-file* (call-with-output-file*
@ -60,7 +61,8 @@
(define (go pch) (define (go pch)
(define l (place-channel-get pch)) (define l (place-channel-get pch))
;; Run the test: ;; Run the test:
(parameterize ([current-command-line-arguments '#()] (parameterize ([current-command-line-arguments (list->vector
(cadddr l))]
[current-directory (caddr l)]) [current-directory (caddr l)])
(dynamic-require (car l) (cadr l))) (dynamic-require (car l) (cadr l)))
;; If the tests use `rackunit`, collect result stats: ;; If the tests use `rackunit`, collect result stats:
@ -78,7 +80,7 @@
;; Run each test in its own place or process, and collect both test ;; Run each test in its own place or process, and collect both test
;; results and whether any output went to stderr. ;; results and whether any output went to stderr.
(define (dynamic-require-elsewhere p d (define (dynamic-require-elsewhere p d args
#:mode [mode (or default-mode #:mode [mode (or default-mode
(if single-file? (if single-file?
'direct 'direct
@ -111,7 +113,7 @@
(define t (define t
(parameterize ([current-output-port stdout] (parameterize ([current-output-port stdout]
[current-error-port stderr] [current-error-port stderr]
[current-command-line-arguments '#()]) [current-command-line-arguments (list->vector args)])
(thread (thread
(lambda () (lambda ()
(dynamic-require p d) (dynamic-require p d)
@ -135,7 +137,7 @@
#:err stderr))) #:err stderr)))
;; Send the module path to test: ;; Send the module path to test:
(place-channel-put pl (list p d (current-directory))) (place-channel-put pl (list p d (current-directory) args))
;; 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))
@ -151,7 +153,8 @@
[current-error-port stderr] [current-error-port stderr]
[current-subprocess-custodian-mode 'kill] [current-subprocess-custodian-mode 'kill]
[current-custodian c]) [current-custodian c])
(process*/ports stdout (apply process*/ports
stdout
(current-input-port) (current-input-port)
stderr stderr
(find-exe) (find-exe)
@ -161,7 +164,8 @@
"(dynamic-require '(submod compiler/commands/test process) #f)" "(dynamic-require '(submod compiler/commands/test process) #f)"
tmp-file tmp-file
(format "~s" (normalize-module-path p)) (format "~s" (normalize-module-path p))
(format "~s" d)))) (format "~s" d)
args)))
(define proc (list-ref ps 4)) (define proc (list-ref ps 4))
(unless (sync/timeout timeout (thread (lambda () (proc 'wait)))) (unless (sync/timeout timeout (thread (lambda () (proc 'wait))))
@ -226,7 +230,7 @@
(append mod '(config)) (append mod '(config))
(error 'test "cannot add test-config submodule to path: ~s" mod))) (error 'test "cannot add test-config submodule to path: ~s" mod)))
(define (dynamic-require* p d try-config?) (define (dynamic-require* p d args try-config?)
(define lookup (define lookup
(or (cond (or (cond
[(not try-config?) #f] [(not try-config?) #f]
@ -235,7 +239,7 @@
[else #f]) [else #f])
(lambda (what get-default) (get-default)))) (lambda (what get-default) (get-default))))
(dynamic-require-elsewhere (dynamic-require-elsewhere
p d p d args
#:timeout (if default-timeout #:timeout (if default-timeout
(lookup 'timeout (lookup 'timeout
(lambda () default-timeout)) (lambda () default-timeout))
@ -353,7 +357,7 @@
;; Perform test of one module (in parallel, as allowed by ;; Perform test of one module (in parallel, as allowed by
;; `task-sema`): ;; `task-sema`):
(define (test-module p mod try-config? #:sema continue-sema) (define (test-module p mod args try-config? #:sema continue-sema)
(call-with-semaphore (call-with-semaphore
task-sema ; limits parallelism task-sema ; limits parallelism
(lambda () (lambda ()
@ -366,17 +370,20 @@
(set! ids (cdr ids)) (set! ids (cdr ids))
(unless quiet? (unless quiet?
;; in lock, so printouts are not interleaved ;; in lock, so printouts are not interleaved
(printf "raco test: ~a~s\n" (printf "raco test: ~a~s~a\n"
(if (jobs . <= . 1) (if (jobs . <= . 1)
"" ""
(format "~a " id)) (format "~a " id))
(let ([m (normalize-module-path p)]) (let ([m (normalize-module-path p)])
(if (and (pair? mod) (eq? 'submod (car mod))) (if (and (pair? mod) (eq? 'submod (car mod)))
(list* 'submod m (cddr mod)) (list* 'submod m (cddr mod))
m)))) m))
(apply string-append
(for/list ([a (in-list args)])
(format " ~s" (format "~a" a))))))
id))) id)))
(begin0 (begin0
(dynamic-require* mod 0 try-config?) (dynamic-require* mod 0 args try-config?)
(call-with-semaphore (call-with-semaphore
ids-lock ids-lock
(lambda () (lambda ()
@ -410,6 +417,7 @@
(or (not check-suffix?) (or (not check-suffix?)
(regexp-match #rx#"\\.rkt$" (path->bytes p))) (regexp-match #rx#"\\.rkt$" (path->bytes p)))
(not (omit-path? p))) (not (omit-path? p)))
(define args (get-cmdline p))
(parameterize ([current-directory (let-values ([(base name dir?) (split-path p)]) (parameterize ([current-directory (let-values ([(base name dir?) (split-path p)])
(if (path? base) (if (path? base)
base base
@ -431,13 +439,13 @@
#f] #f]
[(module-declared? mod #t) [(module-declared? mod #t)
(set! did-one? #t) (set! did-one? #t)
(test-module p mod #t #:sema continue-sema)] (test-module p mod args #t #:sema continue-sema)]
[else [else
(set! something-wasnt-declared? #t) (set! something-wasnt-declared? #t)
#f])) #f]))
(list (list
(and (and run-anyways? something-wasnt-declared?) (and (and run-anyways? something-wasnt-declared?)
(test-module p file-name #f #:sema continue-sema))))))))] (test-module p file-name args #f #:sema continue-sema))))))))]
[(not (file-exists? p)) [(not (file-exists? p))
(error 'test "given path ~e does not exist" p)] (error 'test "given path ~e does not exist" p)]
[else (summary 0 0 #f null)])])) [else (summary 0 0 #f null)])]))
@ -530,6 +538,7 @@
;; Reading "info.rkt" files ;; Reading "info.rkt" files
(define omit-paths (make-hash)) (define omit-paths (make-hash))
(define command-line-arguments (make-hash))
(define collects-cache (make-hash)) (define collects-cache (make-hash))
(define info-done (make-hash)) (define info-done (make-hash))
@ -555,20 +564,33 @@
(define info (get-info/full dir)) (define info (get-info/full dir))
(when info (when info
(define v (info 'test-omit-paths (lambda () '()))) (define v (info 'test-omit-paths (lambda () '())))
(define (bad) (define (bad what v)
(log-error "bad `test-omit-paths` in \"info.rkt\": ~e" v)) (log-error "bad `~a' in \"info.rkt\": ~e" what v))
(cond (cond
[(eq? v 'all) [(eq? v 'all)
(hash-set! omit-paths dir #t)] (hash-set! omit-paths dir #t)]
[(list? v) [(list? v)
(for ([i (in-list v)]) (for ([i (in-list v)])
(unless (path-string? i) (bad)) (unless (path-string? i) (bad 'test-omit-paths v))
(define p (normalize-info-path (path->complete-path i dir))) (define p (normalize-info-path (path->complete-path i dir)))
(define dp (if (directory-exists? p) (define dp (if (directory-exists? p)
(path->directory-path p) (path->directory-path p)
p)) p))
(hash-set! omit-paths dp #t))] (hash-set! omit-paths dp #t))]
[else (bad)])))) [else (bad 'test-omit-paths v)])
(define a (info 'test-command-line-arguments (lambda () '())))
(unless (list? a) (bad 'test-command-line-arguments a))
(for ([arg (in-list a)])
(unless (and (list? arg)
(= 2 (length arg))
(path-string? (car arg))
(list? (cadr arg))
(andmap path-string? (cadr arg)))
(bad 'test-command-line-arguments a))
(hash-set! command-line-arguments
(normalize-info-path (path->complete-path (car arg) dir))
(cadr arg))))))
(define (check-info/parents dir subpath) (define (check-info/parents dir subpath)
(let loop ([dir dir] [subpath subpath]) (let loop ([dir dir] [subpath subpath])
@ -590,6 +612,10 @@
(and (path? base) (and (path? base)
(omit-path? base)))))) (omit-path? base))))))
(define (get-cmdline p)
(let ([p (normalize-info-path p)])
(hash-ref command-line-arguments p null)))
;; -------------------------------------------------- ;; --------------------------------------------------
(define (string->number* what s check) (define (string->number* what s check)
@ -617,7 +643,7 @@
(when (zero? jobs) (when (zero? jobs)
(set-jobs! (processor-count))) (set-jobs! (processor-count)))
(unless default-timeout (unless default-timeout
(set! default-timeout 600)) (set! default-timeout 90))
(set! check-stderr? #t) (set! check-stderr? #t)
(set! quiet-program? #t) (set! quiet-program? #t)
(set! table? #t) (set! table? #t)