diff --git a/collects/tests/typed-scheme/main.rkt b/collects/tests/typed-scheme/main.rkt index 0d83c53246..885ccedcdf 100644 --- a/collects/tests/typed-scheme/main.rkt +++ b/collects/tests/typed-scheme/main.rkt @@ -1,13 +1,12 @@ #lang scheme/base -(provide go go/text) - (require rackunit rackunit/text-ui racket/file mzlib/etc scheme/port compiler/compiler scheme/match mzlib/compile "unit-tests/all-tests.ss" - "unit-tests/test-utils.ss") + "unit-tests/test-utils.ss" + "optimizer/run.rkt") (define (scheme-file? s) (regexp-match ".*[.](rkt|ss|scm)$" (path->string s))) @@ -85,38 +84,6 @@ (succ-tests) (fail-tests))) -(define tests - (test-suite "Typed Scheme Tests" - unit-tests int-tests)) - -(provide tests int-tests unit-tests) - -(define (go tests) (test/gui tests)) -(define (go/text tests) (run-tests tests 'verbose)) - -(define (just-one p*) - (define-values (path p b) (split-path p*)) - (define f - (if (equal? "fail/" (path->string path)) - (lambda (p thnk) - (define-values (pred info) (exn-pred p)) - (parameterize ([error-display-handler void]) - (with-check-info - (['predicates info]) - (check-exn pred thnk)))) - (lambda (p thnk) (check-not-exn thnk)))) - (test-suite - (path->string p) - (f - (build-path path p) - (lambda () - (parameterize ([read-accept-reader #t] - [current-load-relative-directory - (path->complete-path path)] - [current-directory path] - [current-output-port (open-output-nowhere)]) - (dr p)))))) - (define (compile-benchmarks) (define (find dir) (for/list ([d (directory-list dir)] @@ -126,7 +93,7 @@ (define common (collection-path "tests" "racket" "benchmarks" "common" "typed")) (define (mk path) (make-test-suite (path->string path) - (for/list ([p (find path)]) + (for/list ([p (find path)]) (parameterize ([current-load-relative-directory (path->complete-path path)] [current-directory path]) @@ -138,7 +105,38 @@ (mk common) (delete-directory/files (build-path common "compiled")))) -(provide go go/text just-one compile-benchmarks) + +(define (just-one p*) + (define-values (path p b) (split-path p*)) + (define f + (let ([dir (path->string path)]) + (cond [(equal? dir "fail/") + (lambda (p thnk) + (define-values (pred info) (exn-pred p)) + (parameterize ([error-display-handler void]) + (with-check-info + (['predicates info]) + (check-exn pred thnk))))] + [(equal? dir "succeed/") + (lambda (p thnk) (check-not-exn thnk))] + [(equal? dir "optimizer/tests/") + (lambda (p* thnk) (test-opt p))]))) + (test-suite + (path->string p) + (f + (build-path path p) + (lambda () + (parameterize ([read-accept-reader #t] + [current-load-relative-directory + (path->complete-path path)] + [current-directory path] + [current-output-port (open-output-nowhere)]) + (dr p)))))) +(define (go tests) (test/gui tests)) +(define (go/text tests) (run-tests tests 'verbose)) +(provide go go/text just-one + int-tests unit-tests compile-benchmarks + optimization-tests) diff --git a/collects/tests/typed-scheme/optimizer/run.rkt b/collects/tests/typed-scheme/optimizer/run.rkt index c651559ab6..a07eb1de1f 100644 --- a/collects/tests/typed-scheme/optimizer/run.rkt +++ b/collects/tests/typed-scheme/optimizer/run.rkt @@ -2,9 +2,7 @@ (require racket/runtime-path rackunit rackunit/text-ui) -(provide optimization-tests) - -(define show-names? (make-parameter #f)) +(provide optimization-tests test-opt) (define (generate-log name dir flags) ;; some tests require other tests, so some fiddling is required @@ -53,29 +51,7 @@ #:when (regexp-match ".*rkt$" name)) (make-test-suite (path->string name) - (cons (test-suite - "Show Name" - (check-eq? (begin (when (show-names?) (displayln name)) #t) #t)) - (proc name)))))) + (proc name))))) (define optimization-tests (mk-suite "Optimization Tests" tests-dir test-opt)) - - -(define single-test - (command-line - #:once-each - ["--show-names" "show the names of tests as they are run" (show-names? #t)] - ;; we optionally take a test name. if none is given, run everything (#f) - #:args maybe-test-to-run - (and (not (null? maybe-test-to-run)) - (car maybe-test-to-run)))) - -(void ; to suppress output of the return value - (run-tests - (cond [single-test - (let-values ([(base name _) (split-path single-test)]) - (make-test-suite "Single Test" (test-opt name)))] - [else ; default = run everything - optimization-tests]) - 'normal)) diff --git a/collects/tests/typed-scheme/run.rkt b/collects/tests/typed-scheme/run.rkt index 50fd0eb703..9c2ac9be6d 100644 --- a/collects/tests/typed-scheme/run.rkt +++ b/collects/tests/typed-scheme/run.rkt @@ -1,47 +1,39 @@ #lang racket -(require racket/vector racket/gui/dynamic) +(require racket/vector racket/gui/dynamic rackunit) (require "main.ss") (define exec (make-parameter go/text)) -(define the-tests (make-parameter #f)) (define nightly? (make-parameter #f)) (define unit? (make-parameter #f)) (define int? (make-parameter #f)) (define opt? (make-parameter #f)) (define bench? (make-parameter #f)) +(define single (make-parameter #f)) (current-namespace (make-base-namespace)) (command-line #:once-each ["--unit" "run the unit tests" (unit? #t)] ["--int" "run the integration tests" (int? #t)] - ["--nightly" "for the nightly builds" (begin (nightly? #t) (unit? #t) (int? #t))] - ["--just" path "run only this test" (the-tests (just-one path))] - ["--opt" "run the optimizer tests" (opt? #t)] + ["--opt" "run the optimization tests" (opt? #t)] ["--benchmarks" "compile the typed benchmarks" (bench? #t)] + ["--just" path "run only this test" (single (just-one path))] + ["--nightly" "for the nightly builds" (begin (nightly? #t) (unit? #t) (int? #t) (opt? #t))] ["--all" "run all tests" (begin (unit? #t) (int? #t) (opt? #t) (bench? #t))] ["--gui" "run using the gui" (if (gui-available?) (begin (exec go)) - (error "GUI not available"))] - ) + (error "GUI not available"))]) -(the-tests - (cond [(and (unit?) (int?)) tests] - [(unit?) unit-tests] - [(int?) int-tests] - [(or (the-tests) (bench?) (opt?)) (the-tests)] - [else - (error "You must specify which tests should be run. See --help for more info.\n")])) - -(cond [(and (nightly?) (eq? 'cgc (system-type 'gc))) - (printf "Skipping Typed Racket tests.\n")] - [(when (the-tests) - (unless (= 0 ((exec) (the-tests))) - (eprintf "Typed Racket Tests did not pass.\n"))) - (when (opt?) - (parameterize ([current-command-line-arguments #()]) - (dynamic-require '(file "optimizer/run.rkt") #f))) - (when (bench?) - (unless (= 0 ((exec) (compile-benchmarks))) - (error "Typed Racket Tests did not pass.\n")))]) +(if (and (nightly?) (eq? 'cgc (system-type 'gc))) + (printf "Skipping Typed Racket tests.\n") + (let ([to-run (cond [(single) (single)] + [else + (make-test-suite + "Typed Racket Tests" + (append (if (unit?) (list unit-tests) '()) + (if (int?) (list int-tests) '()) + (if (opt?) (list optimization-tests) '()) + (if (bench?) (list (compile-benchmarks)) '())))])]) + (unless (= 0 ((exec) to-run)) + (eprintf "Typed Racket Tests did not pass.\n"))))