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

raco test: run configure-runtime submodule of module to test

Browse Source 
Unless `-s` or `--submodule` is specified, and as long as each
test is run in its own place or process, require a `configure-runtime`
submodule of the specified module before running the module or its
`test` submodule.

For example, this change makes `raco test` run `htdp/bsl` tests
with printing configured correctly for `htdp/bsl`.
This commit is contained in:
Matthew Flatt 2015-09-07 11:59:15 -06:00
parent 7d60d6d885
commit 796b0796f4
4 changed files with 70 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
compiler-lib/compiler/commands/test.rkt
View File

@ -24,6 +24,7 @@
;; entry is required in "info.rkt". ;; entry is required in "info.rkt".
(define submodules '()) ; '() means "default" (define submodules '()) ; '() means "default"
(define configure-runtime 'default)
(define first-avail? #f) (define first-avail? #f)
(define run-anyways? #t) (define run-anyways? #t)
(define quiet? #f) (define quiet? #f)
@ -61,8 +62,9 @@
(define argv (current-command-line-arguments)) (define argv (current-command-line-arguments))
(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 rt-module (read (open-input-string (vector-ref argv 2))))
(define args (list-tail (vector->list argv) 3)) (define d (read (open-input-string (vector-ref argv 3))))
(define args (list-tail (vector->list argv) 4))
;; In case PLTUSERHOME is set, make sure relevant ;; In case PLTUSERHOME is set, make sure relevant
;; directories exist: ;; directories exist:
@ -71,6 +73,7 @@
(ready-dir (find-system-path 'doc-dir)) (ready-dir (find-system-path 'doc-dir))
(parameterize ([current-command-line-arguments (list->vector args)]) (parameterize ([current-command-line-arguments (list->vector args)])
(when rt-module (dynamic-require rt-module d))
(dynamic-require test-module d) (dynamic-require test-module d)
((executable-yield-handler) 0)) ((executable-yield-handler) 0))
@ -90,9 +93,10 @@
(define l (place-channel-get pch)) (define l (place-channel-get pch))
;; Run the test: ;; Run the test:
(parameterize ([current-command-line-arguments (list->vector (parameterize ([current-command-line-arguments (list->vector
(cadddr l))] (cadddr (cdr l)))]
[current-directory (caddr l)]) [current-directory (cadddr l)])
(dynamic-require (car l) (cadr l)) (when (cadr l) (dynamic-require (cadr l) (caddr l)))
(dynamic-require (car l) (caddr l))
((executable-yield-handler) 0)) ((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
@ -110,7 +114,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 args (define (dynamic-require-elsewhere p rt-p d args
#:id id #:id id
#:mode [mode (or default-mode #:mode [mode (or default-mode
(if single-file? (if single-file?
@ -155,7 +159,8 @@
(when lock-name (when lock-name
(fprintf stdout "raco test:~a @(lock-name ~s)\n" (fprintf stdout "raco test:~a @(lock-name ~s)\n"
id id
lock-name))) lock-name))
(flush-output stdout))
(define-values (result-code test-results) (define-values (result-code test-results)
(case mode (case mode
@ -169,6 +174,7 @@
[current-command-line-arguments (list->vector args)]) [current-command-line-arguments (list->vector args)])
(thread (thread
(lambda () (lambda ()
(when rt-p (dynamic-require rt-p d))
(dynamic-require p d) (dynamic-require p d)
((executable-yield-handler) 0) ((executable-yield-handler) 0)
(set! done? #t))))) (set! done? #t)))))
@ -192,7 +198,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) args)) (place-channel-put pl (list p rt-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))
@ -234,6 +240,7 @@
"(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" (normalize-module-path rt-p))
(format "~s" d) (format "~s" d)
args))) args)))
(define proc (list-ref ps 4)) (define proc (list-ref ps 4))
@ -319,7 +326,7 @@
(append mod '(config)) (append mod '(config))
(error test-exe-name "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 rt-p d
#:id id #:id id
#:try-config? try-config? #:try-config? try-config?
#:args args #:args args
@ -335,7 +342,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 args p rt-p d args
#:id id #:id id
#:responsible (lookup 'responsible #:responsible (lookup 'responsible
(lambda () responsible)) (lambda () responsible))
@ -461,7 +468,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 (define (test-module p mod rt-mod
#:sema continue-sema #:sema continue-sema
#:try-config? try-config? #:try-config? try-config?
#:args [args '()] #:args [args '()]
@ -513,7 +520,7 @@
m))))) m)))))
(loop))))))) (loop)))))))
(begin0 (begin0
(dynamic-require* mod 0 (dynamic-require* mod rt-mod 0
#:id (if (jobs . <= . 1) #:id (if (jobs . <= . 1)
"" ""
(format " ~a" id)) (format " ~a" id))
@ -577,8 +584,8 @@
base base
(current-directory)))]) (current-directory)))])
(define file-name (file-name-from-path p)) (define file-name (file-name-from-path p))
(define (test-this-module mod try-config?) (define (test-this-module mod rt-mod try-config?)
(test-module p mod (test-module p mod rt-mod
#:try-config? try-config? #:try-config? try-config?
#:sema continue-sema #:sema continue-sema
#:args args #:args args
@ -589,7 +596,12 @@
(with-summary (with-summary
`(file ,p) `(file ,p)
(let ([something-wasnt-declared? #f] (let ([something-wasnt-declared? #f]
[did-one? #f]) [did-one? #f]
[rt-mod
(and configure-runtime
(let ([mod `(submod ,file-name configure-runtime)])
(and (module-declared? mod #t)
mod)))])
(filter (filter
values values
(append (append
@ -612,13 +624,13 @@
'ok)) 'ok))
=> (lambda (mode) => (lambda (mode)
(set! did-one? #t) (set! did-one? #t)
(test-this-module mod (eq? mode 'ok)))] (test-this-module mod rt-mod (eq? mode 'ok)))]
[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-this-module file-name #f))))))))] (test-this-module file-name rt-mod #f))))))))]
[else (summary 0 0 #f null 0)])])) [else (summary 0 0 #f null 0)])]))
(module paths racket/base (module paths racket/base
@ -974,6 +986,9 @@
[("--first-avail") [("--first-avail")
"Run only the first available submodule" "Run only the first available submodule"
(set! first-avail? #f)] (set! first-avail? #f)]
[("--configure-runtime")
"Run the `configure-runtime' submodule"
(set! configure-runtime #t)]
#:once-any #:once-any
[("--direct") [("--direct")
"Run tests directly (default for a single file)" "Run tests directly (default for a single file)"
@ -1021,6 +1036,11 @@
#:args file-or-directory #:args file-or-directory
(begin (unless (= 1 (length file-or-directory)) (begin (unless (= 1 (length file-or-directory))
(set! single-file? #f)) (set! single-file? #f))
(when (and (eq? configure-runtime 'default)
(or (and (not single-file?)
(not (memq default-mode '(process place))))
(not (null? submodules))))
(set! configure-runtime #f))
(define sum (define sum
;; The #:sema argument everywhre makes tests start ;; The #:sema argument everywhre makes tests start
;; in a deterministic order: ;; in a deterministic order:

2
compiler-test/tests/compiler/test/racket.rkt Normal file
View File

@ -0,0 +1,2 @@
#lang racket/base
(list 1 2)

29
compiler-test/tests/compiler/test/runtime.rkt Normal file
View File

@ -0,0 +1,29 @@
#lang racket/base
(require racket/system
compiler/find-exe)
(define exe (find-exe))
(define (try mode mod expect)
(printf "trying ~s ~s\n" mod mode)
(define s (open-output-bytes))
(parameterize ([current-output-port s])
(system* exe "-l-" "raco" "test"
mode "-l" (string-append "tests/compiler/test/" mod)))
(define last-line
(for/fold ([prev #f]) ([s (in-lines (open-input-bytes (get-output-bytes s)))])
(if (or (eof-object? s)
(equal? s "1 test passed"))
prev
s)))
(unless (equal? expect last-line)
(error 'runtime "test failed\n module: ~s\n expected: ~s\n got: ~s"
mod expect last-line)))
(for ([mod '("--direct" "--place" "--process")])
(try mod "racket.rkt" "'(1 2)")
(try mod "scheme.rkt" "(1 2)"))

2
compiler-test/tests/compiler/test/scheme.rkt Normal file
View File

@ -0,0 +1,2 @@
#lang scheme/base
(list 1 2)