diff --git a/collects/tests/typed-scheme/main.ss b/collects/tests/typed-scheme/main.ss index 81726da0..520ac6a2 100644 --- a/collects/tests/typed-scheme/main.ss +++ b/collects/tests/typed-scheme/main.ss @@ -4,8 +4,8 @@ (require (planet schematics/schemeunit/test) (planet schematics/schemeunit/text-ui) - #;(planet schematics/schemeunit/graphical-ui) mzlib/etc + compiler/compiler scheme/match "unit-tests/all-tests.ss" "unit-tests/test-utils.ss") @@ -30,11 +30,10 @@ (define (exn-pred p) (let ([sexp (with-handlers - ([values (lambda _ #f)]) - (let ([prt (open-input-file p)]) - (begin0 (begin (read-line prt 'any) - (read prt)) - (close-input-port prt))))]) + ([exn:fail? (lambda _ #f)]) + (with-input-from-file p + (lambda () + (read-line 'any) (read))))]) (match sexp [(list-rest 'exn-pred e) (eval `(exn-matches . ,e) (namespace-anchor->namespace a))] @@ -52,20 +51,23 @@ (build-path path p) (lambda () (parameterize ([read-accept-reader #t] - [current-load-relative-directory - path]) + [current-load-relative-directory path] + [current-directory path]) (with-output-to-file "/dev/null" #:exists 'append (lambda () (loader p))))))))) (apply test-suite dir tests))) +(define (dr p) + ((compile-zos #f) (list p) 'auto) + (parameterize ([current-namespace (make-base-empty-namespace)]) + (dynamic-require `(file ,(path->string p)) #f))) + (define succ-tests (mk-tests "succeed" - (lambda (p) (parameterize ([current-namespace (make-base-empty-namespace)]) - (dynamic-require `(file ,(path->string p)) #f))) + dr (lambda (p thnk) (check-not-exn thnk)))) (define fail-tests (mk-tests "fail" - (lambda (p) (parameterize ([current-namespace (make-base-empty-namespace)]) - (dynamic-require `(file ,(path->string p)) #f))) + dr (lambda (p thnk) (define-values (pred info) (exn-pred p)) (with-check-info diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index bb0c8dcb..91d8d5f7 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -11,7 +11,7 @@ type-name-env init-envs mutated-vars effect-rep type-annotation type-utils) (for-syntax (private tc-utils typechecker base-env type-env)) - (for-template (private base-env))) + (for-template (private base-env base-types))) (require (schemeunit))