diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index c1afd89f4a..c9d8b64812 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "10sep2008") +#lang scheme/base (provide stamp) (define stamp "11sep2008") diff --git a/collects/tests/run-automated-tests.ss b/collects/tests/run-automated-tests.ss index 6e916361d0..2656de69b5 100755 --- a/collects/tests/run-automated-tests.ss +++ b/collects/tests/run-automated-tests.ss @@ -31,7 +31,8 @@ (define tests '([load "mzscheme/quiet.ss" (lib "scheme/init")] [require "typed-scheme/main.ss"] - [require "match/plt-match-tests.ss"])) + [require "match/plt-match-tests.ss"] + [require "stepper/automatic-tests.ss"])) (require scheme/runtime-path) diff --git a/collects/tests/stepper/automatic-tests.ss b/collects/tests/stepper/automatic-tests.ss index 7c14acc484..685b42d5a2 100644 --- a/collects/tests/stepper/automatic-tests.ss +++ b/collects/tests/stepper/automatic-tests.ss @@ -1,7 +1,8 @@ (module automatic-tests mzscheme (require "through-tests.ss") - (parameterize ([display-only-errors #t]) - (if (run-all-tests-except '(check-expect begin-let-bug prims qq-splice time set! local-set! lazy1 lazy2 lazy3)) + (parameterize ([display-only-errors #t] + [current-output-port (open-output-string)]) + (if (run-all-tests-except '(check-error begin-let-bug prims qq-splice time set! local-set! lazy1 lazy2 lazy3)) (exit 1) (exit 0)))) diff --git a/collects/tests/stepper/run-nightly-tests.ss b/collects/tests/stepper/run-nightly-tests.ss deleted file mode 100644 index 468cd45296..0000000000 --- a/collects/tests/stepper/run-nightly-tests.ss +++ /dev/null @@ -1,5 +0,0 @@ -(module run-nightly-tests mzscheme - (require "through-tests.ss") - - (parameterize ([display-only-errors #t]) - (run-all-tests-except '(prims qq-splice time set! local-set! lazy1 lazy2 lazy3)))) \ No newline at end of file diff --git a/collects/tests/stepper/through-tests.ss b/collects/tests/stepper/through-tests.ss index 9a2165ee0e..d99ea1d9ed 100755 --- a/collects/tests/stepper/through-tests.ss +++ b/collects/tests/stepper/through-tests.ss @@ -1368,21 +1368,6 @@ (before-after (9 (list 'check-expect-failed 7 17) (list 'check-expect-passed 2 2) (check-expect (hilite (+ 2 2)) 4)) (9 (list 'check-expect-failed 7 17) (list 'check-expect-passed 2 2) (check-expect (hilite 4) 4)))))) - (t1 check-expect-2 - (test-upto-int/lam - "(check-expect (+ 3 4) (+ 8 9)) (check-expect (+ 3 1) 4) (+ 4 5)" - `((before-after ((hilite (+ 4 5))) - ((hilite 9))) - (before-after (9 (check-expect (+ 3 4) (hilite (+ 8 9)))) - (9 (check-expect (+ 3 4) (hilite 17)))) - (before-after (9 (check-expect (hilite (+ 3 4)) 17)) - (9 (check-expect (hilite 7) 17))) - (before-after (9 (check-expect (hilite (+ 3 1)) 4)) - (9 (check-expect (hilite 4) 4)))))) - - - - (t1 check-within (test-bwla-to-int/lam "(check-within (+ 3 4) (+ 8 10) (+ 10 90)) (check-expect (+ 1 1) 2)(+ 4 5)" diff --git a/collects/tests/typed-scheme/fail/values-dots.ss b/collects/tests/typed-scheme/fail/values-dots.ss index 6c08fff545..f92743faf3 100644 --- a/collects/tests/typed-scheme/fail/values-dots.ss +++ b/collects/tests/typed-scheme/fail/values-dots.ss @@ -7,8 +7,8 @@ (: map-with-funcs (All (b ...) ((b ... b -> b) ... b -> (b ... b -> (values b ... b))))) (define (map-with-funcs . fs) (lambda bs - (apply values* (map (lambda: ([f : (b ... b -> b)]) - (apply f bs)) fs)))) + (apply values (map (lambda: ([f : (b ... b -> b)]) + (apply f bs)) fs)))) (map-with-funcs (lambda () 1)) diff --git a/collects/tests/typed-scheme/succeed/nested-poly.ss b/collects/tests/typed-scheme/succeed/nested-poly.ss index 785ee9a5df..ac8bb3cd8c 100644 --- a/collects/tests/typed-scheme/succeed/nested-poly.ss +++ b/collects/tests/typed-scheme/succeed/nested-poly.ss @@ -13,7 +13,7 @@ (B ... B -> (values A ... A)))))) (define (map-with-funcs . fs) (lambda as - (apply values* (map (lambda: ([f : (B ... B -> A)]) + (apply values (map (lambda: ([f : (B ... B -> A)]) (apply f as)) fs)))) diff --git a/collects/tests/typed-scheme/succeed/values-dots.ss b/collects/tests/typed-scheme/succeed/values-dots.ss index 0078526faa..1c853f50b0 100644 --- a/collects/tests/typed-scheme/succeed/values-dots.ss +++ b/collects/tests/typed-scheme/succeed/values-dots.ss @@ -5,16 +5,16 @@ (call-with-values (lambda () (values 1 2)) (lambda: ([x : Number] [y : Number]) (+ x y))) -(#{call-with-values* @ Integer Integer Integer} (lambda () (values 1 2)) (lambda: ([x : Integer] [y : Integer]) (+ x y))) +(#{call-with-values @ Integer Integer Integer} (lambda () (values 1 2)) (lambda: ([x : Integer] [y : Integer]) (+ x y))) -(call-with-values* (lambda () (values 1 2)) (lambda: ([x : Integer] [y : Integer]) (+ x y))) +(call-with-values (lambda () (values 1 2)) (lambda: ([x : Integer] [y : Integer]) (+ x y))) (: map-with-funcs (All (b ...) ((b ... b -> b) ... b -> (b ... b -> (values b ... b))))) (define (map-with-funcs . fs) (lambda bs - (apply values* (map (lambda: ([f : (b ... b -> b)]) - (apply f bs)) fs)))) + (apply values (map (lambda: ([f : (b ... b -> b)]) + (apply f bs)) fs)))) (map-with-funcs + - * /) diff --git a/collects/tests/typed-scheme/unit-tests/all-tests.ss b/collects/tests/typed-scheme/unit-tests/all-tests.ss index aca0a4d12c..1fe728d05b 100644 --- a/collects/tests/typed-scheme/unit-tests/all-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/all-tests.ss @@ -12,7 +12,7 @@ "subst-tests.ss" "infer-tests.ss") -(require (private planet-requires infer infer-dummy)) +(require (utils planet-requires) (r:infer infer infer-dummy)) (require (schemeunit)) diff --git a/collects/tests/typed-scheme/unit-tests/infer-tests.ss b/collects/tests/typed-scheme/unit-tests/infer-tests.ss index f1d5e22b0d..aef624b748 100644 --- a/collects/tests/typed-scheme/unit-tests/infer-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/infer-tests.ss @@ -1,7 +1,10 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base)) -(require (private planet-requires type-effect-convenience type-rep union infer type-utils) - (prefix-in table: (private tables))) +(require (utils planet-requires) + (rep type-rep) + (r:infer infer) + (private type-effect-convenience union type-utils) + (prefix-in table: (utils tables))) (require (schemeunit)) diff --git a/collects/tests/typed-scheme/unit-tests/module-tests.ss b/collects/tests/typed-scheme/unit-tests/module-tests.ss index 51406fb008..490c1c2a89 100644 --- a/collects/tests/typed-scheme/unit-tests/module-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/module-tests.ss @@ -1,6 +1,6 @@ #lang scheme (require "test-utils.ss") -(require (private planet-requires)) +(require (utils planet-requires)) (require (schemeunit)) (provide module-tests) diff --git a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss index aa3882fd38..fedf84fb81 100644 --- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss @@ -1,8 +1,10 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base)) -(require (private planet-requires type-comparison parse-type type-rep - tc-utils type-environments type-alias-env subtype - type-name-env init-envs union type-utils)) +(require (utils planet-requires tc-utils) + (env type-alias-env type-environments type-name-env init-envs) + (rep type-rep) + (private type-comparison parse-type subtype + union type-utils)) (require (rename-in (private type-effect-convenience) [-> t:->]) (except-in (private base-types) Un) diff --git a/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss b/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss index ca83402b66..20da5c73c3 100644 --- a/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss @@ -1,6 +1,9 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base)) -(require (private type-rep type-effect-convenience planet-requires remove-intersect subtype union infer)) +(require (rep type-rep) + (utils planet-requires) + (r:infer infer) + (private type-effect-convenience remove-intersect subtype union)) (require (schemeunit)) diff --git a/collects/tests/typed-scheme/unit-tests/subst-tests.ss b/collects/tests/typed-scheme/unit-tests/subst-tests.ss index 6c89d4ef6f..10a35fc98a 100644 --- a/collects/tests/typed-scheme/unit-tests/subst-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subst-tests.ss @@ -1,7 +1,9 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base)) -(require (private planet-requires type-utils type-effect-convenience type-rep)) +(require (utils planet-requires) + (rep type-rep) + (private type-utils type-effect-convenience)) (require (schemeunit)) (define-syntax-rule (s img var tgt result) diff --git a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss index f4bc99125d..83bb3e9a51 100644 --- a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss @@ -2,8 +2,12 @@ (require "test-utils.ss") -(require (private subtype type-rep type-effect-convenience - planet-requires init-envs type-environments union infer infer-dummy)) +(require (private subtype type-effect-convenience union) + (rep type-rep) + (utils planet-requires) + (env init-envs type-environments) + (r:infer infer infer-dummy)) + (require (schemeunit) (for-syntax scheme/base)) diff --git a/collects/tests/typed-scheme/unit-tests/test-utils.ss b/collects/tests/typed-scheme/unit-tests/test-utils.ss index f5c848fa04..b160cacdf9 100644 --- a/collects/tests/typed-scheme/unit-tests/test-utils.ss +++ b/collects/tests/typed-scheme/unit-tests/test-utils.ss @@ -3,25 +3,12 @@ (require scheme/require-syntax scheme/match + typed-scheme/utils/utils (for-syntax scheme/base)) -(define-require-syntax private - (lambda (stx) - (syntax-case stx () - [(_ id ...) - (andmap identifier? (syntax->list #'(id ...))) - (with-syntax ([(id* ...) (map (lambda (id) (datum->syntax - id - (string->symbol - (string-append - "typed-scheme/private/" - (symbol->string (syntax-e id)))) - id id)) - (syntax->list #'(id ...)))]) - (syntax/loc stx (combine-in id* ...)))]))) - -(require (private planet-requires type-comparison utils type-utils)) +(require (utils planet-requires) (private type-comparison type-utils)) +(provide private typecheck (rename-out [infer r:infer]) utils env rep) (require (schemeunit)) (define (mk-suite ts) diff --git a/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss b/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss index 80e471b00c..167db51eb7 100644 --- a/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss +++ b/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss @@ -1,8 +1,10 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base)) -(require (private planet-requires type-annotation tc-utils type-rep type-effect-convenience type-environments - parse-type init-envs type-name-env)) +(require (private type-annotation type-effect-convenience parse-type) + (env type-environments type-name-env init-envs) + (utils planet-requires tc-utils) + (rep type-rep)) (require (schemeunit)) diff --git a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss index 6488d47b16..899b8e1e97 100644 --- a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss @@ -1,7 +1,8 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base)) -(require (private planet-requires type-rep type-comparison type-effect-convenience union subtype)) +(require (utils planet-requires) (rep type-rep) + (private type-comparison type-effect-convenience union subtype)) (require (schemeunit)) (provide type-equal-tests) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index a5263dd32b..fee35aa2fc 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -3,14 +3,16 @@ (require "test-utils.ss" (for-syntax scheme/base) (for-template scheme/base)) -(require (private base-env)) +(require (private base-env mutated-vars type-utils union prims type-effect-convenience type-annotation) + (typecheck typechecker) + (rep type-rep effect-rep) + (utils tc-utils planet-requires) + (env type-name-env type-environments init-envs)) -(require (private planet-requires typechecker - type-rep type-effect-convenience type-env - prims type-environments tc-utils union - type-name-env init-envs mutated-vars - effect-rep type-annotation type-utils) - (for-syntax (private tc-utils typechecker base-env type-env)) +(require (for-syntax (utils tc-utils) + (typecheck typechecker) + (env type-env) + (private base-env)) (for-template (private base-env base-types))) (require (schemeunit)) @@ -669,7 +671,7 @@ (tc-l #t (-val #t)) (tc-l "foo" -String) (tc-l foo (-val 'foo)) - (tc-l #:foo -Keyword) + (tc-l #:foo (-val '#:foo)) (tc-l #f (-val #f)) (tc-l #"foo" -Bytes) [tc-l () (-val null)] diff --git a/collects/typed-scheme/private/init-envs.ss b/collects/typed-scheme/env/init-envs.ss similarity index 90% rename from collects/typed-scheme/private/init-envs.ss rename to collects/typed-scheme/env/init-envs.ss index d0dac77c0c..4a03b9108d 100644 --- a/collects/typed-scheme/private/init-envs.ss +++ b/collects/typed-scheme/env/init-envs.ss @@ -1,11 +1,16 @@ #lang scheme/base (provide (all-defined-out)) +(require "../utils/utils.ss") -(require "type-env.ss" "type-rep.ss" "type-name-env.ss" "union.ss" "effect-rep.ss" - "type-effect-convenience.ss" "type-alias-env.ss" - "type-alias-env.ss") -(require mzlib/pconvert scheme/match mzlib/shared - (for-template mzlib/pconvert mzlib/shared scheme/base "type-rep.ss" "union.ss" "effect-rep.ss")) +(require "type-env.ss" + "type-name-env.ss" + (rep type-rep effect-rep) + (for-template (rep type-rep effect-rep) + (private union) + mzlib/pconvert mzlib/shared scheme/base) + (private type-effect-convenience union) + "type-alias-env.ss" + mzlib/pconvert scheme/match mzlib/shared) (define (initialize-type-name-env initial-type-names) (for-each (lambda (nm/ty) (register-resolved-type-alias (car nm/ty) (cadr nm/ty))) initial-type-names)) diff --git a/collects/typed-scheme/private/lexical-env.ss b/collects/typed-scheme/env/lexical-env.ss similarity index 90% rename from collects/typed-scheme/private/lexical-env.ss rename to collects/typed-scheme/env/lexical-env.ss index e5946a3126..63a1295b76 100644 --- a/collects/typed-scheme/private/lexical-env.ss +++ b/collects/typed-scheme/env/lexical-env.ss @@ -1,6 +1,12 @@ #lang scheme/base -(require "type-environments.ss" "tc-utils.ss" "type-env.ss" "mutated-vars.ss" "type-utils.ss" "type-effect-convenience.ss") +(require (except-in "../utils/utils.ss" extend)) +(require "type-environments.ss" + (utils tc-utils) + "type-env.ss" + (private mutated-vars) + (private type-utils) + (private type-effect-convenience)) (provide (all-defined-out)) diff --git a/collects/typed-scheme/private/type-alias-env.ss b/collects/typed-scheme/env/type-alias-env.ss similarity index 96% rename from collects/typed-scheme/private/type-alias-env.ss rename to collects/typed-scheme/env/type-alias-env.ss index 0be4da74a5..dd9183d32c 100644 --- a/collects/typed-scheme/private/type-alias-env.ss +++ b/collects/typed-scheme/env/type-alias-env.ss @@ -1,7 +1,8 @@ #lang scheme/base +(require (except-in "../utils/utils.ss" extend)) (require syntax/boundmap - "tc-utils.ss" + (utils tc-utils) mzlib/trace scheme/match) diff --git a/collects/typed-scheme/private/type-env.ss b/collects/typed-scheme/env/type-env.ss similarity index 95% rename from collects/typed-scheme/private/type-env.ss rename to collects/typed-scheme/env/type-env.ss index d9dafeeffc..59eb3cad7e 100644 --- a/collects/typed-scheme/private/type-env.ss +++ b/collects/typed-scheme/env/type-env.ss @@ -1,7 +1,9 @@ #lang scheme/base +(require (except-in "../utils/utils.ss" extend)) (require syntax/boundmap - "tc-utils.ss" "type-utils.ss") + (utils tc-utils) + (private type-utils)) (provide register-type finish-register-type diff --git a/collects/typed-scheme/private/type-environments.ss b/collects/typed-scheme/env/type-environments.ss similarity index 96% rename from collects/typed-scheme/private/type-environments.ss rename to collects/typed-scheme/env/type-environments.ss index 536fdfc9c9..0f159ec0bd 100644 --- a/collects/typed-scheme/private/type-environments.ss +++ b/collects/typed-scheme/env/type-environments.ss @@ -10,8 +10,9 @@ initial-tvar-env with-dotted-env/extend) +(require (prefix-in r: "../utils/utils.ss")) (require scheme/match - "tc-utils.ss") + (r:utils tc-utils)) ;; eq? has the type of equal?, and l is an alist (with conses!) (define-struct env (eq? l)) diff --git a/collects/typed-scheme/private/type-name-env.ss b/collects/typed-scheme/env/type-name-env.ss similarity index 93% rename from collects/typed-scheme/private/type-name-env.ss rename to collects/typed-scheme/env/type-name-env.ss index 370b77e7c6..d6773f0ea5 100644 --- a/collects/typed-scheme/private/type-name-env.ss +++ b/collects/typed-scheme/env/type-name-env.ss @@ -1,9 +1,10 @@ #lang scheme/base +(require "../utils/utils.ss") (require syntax/boundmap mzlib/trace - "tc-utils.ss" - "type-utils.ss") + (utils tc-utils) + (private type-utils)) (provide register-type-name lookup-type-name diff --git a/collects/typed-scheme/private/constraint-structs.ss b/collects/typed-scheme/infer/constraint-structs.ss similarity index 94% rename from collects/typed-scheme/private/constraint-structs.ss rename to collects/typed-scheme/infer/constraint-structs.ss index def84ae0a6..d5c970348b 100644 --- a/collects/typed-scheme/private/constraint-structs.ss +++ b/collects/typed-scheme/infer/constraint-structs.ss @@ -1,6 +1,7 @@ #lang scheme/base -(require "type-rep.ss" +(require (except-in "../utils/utils.ss" extend)) +(require (rep type-rep) scheme/contract) ;; S, T types diff --git a/collects/typed-scheme/private/constraints.ss b/collects/typed-scheme/infer/constraints.ss similarity index 94% rename from collects/typed-scheme/private/constraints.ss rename to collects/typed-scheme/infer/constraints.ss index 2697109ebe..3dff2c088a 100644 --- a/collects/typed-scheme/private/constraints.ss +++ b/collects/typed-scheme/infer/constraints.ss @@ -1,8 +1,9 @@ #lang scheme/unit -(require "type-effect-convenience.ss" "type-rep.ss" - "type-utils.ss" "union.ss" "tc-utils.ss" - "subtype.ss" "utils.ss" +(require (except-in "../utils/utils.ss" extend)) +(require (private type-effect-convenience type-utils union subtype) + (rep type-rep) + (utils tc-utils) "signatures.ss" "constraint-structs.ss" scheme/match) diff --git a/collects/typed-scheme/private/dmap.ss b/collects/typed-scheme/infer/dmap.ss similarity index 92% rename from collects/typed-scheme/private/dmap.ss rename to collects/typed-scheme/infer/dmap.ss index ef2112bae1..9592668061 100644 --- a/collects/typed-scheme/private/dmap.ss +++ b/collects/typed-scheme/infer/dmap.ss @@ -1,6 +1,8 @@ #lang scheme/unit -(require "signatures.ss" "utils.ss" "tc-utils.ss" "constraint-structs.ss" +(require (except-in "../utils/utils.ss" extend)) +(require "signatures.ss" "constraint-structs.ss" + (utils tc-utils) scheme/match) (import constraints^) diff --git a/collects/typed-scheme/infer/infer-dummy.ss b/collects/typed-scheme/infer/infer-dummy.ss new file mode 100644 index 0000000000..d83922a61e --- /dev/null +++ b/collects/typed-scheme/infer/infer-dummy.ss @@ -0,0 +1,8 @@ +#lang scheme/base +(require "../utils/utils.ss") + +(require (rep type-rep) (utils tc-utils)) + +(define infer-param (make-parameter (lambda e (int-err "infer not initialized")))) +(define (unify X S T) ((infer-param) X S T (make-Univ) null)) +(provide unify infer-param) \ No newline at end of file diff --git a/collects/typed-scheme/private/infer-unit.ss b/collects/typed-scheme/infer/infer-unit.ss similarity index 92% rename from collects/typed-scheme/private/infer-unit.ss rename to collects/typed-scheme/infer/infer-unit.ss index 27ec65707c..c640d363ba 100644 --- a/collects/typed-scheme/private/infer-unit.ss +++ b/collects/typed-scheme/infer/infer-unit.ss @@ -1,12 +1,14 @@ #lang scheme/unit -(require "type-effect-convenience.ss" "type-rep.ss" "effect-rep.ss" "rep-utils.ss" - "free-variance.ss" - (except-in "type-utils.ss" Dotted) - "union.ss" "tc-utils.ss" "type-name-env.ss" - "subtype.ss" "remove-intersect.ss" "signatures.ss" "utils.ss" +(require (except-in "../utils/utils.ss")) +(require (rep free-variance type-rep effect-rep rep-utils) + (private type-effect-convenience union subtype remove-intersect) + (utils tc-utils) + (env type-name-env) + (except-in (private type-utils) Dotted) "constraint-structs.ss" - (only-in "type-environments.ss" lookup current-tvars) + "signatures.ss" + (only-in (env type-environments) lookup current-tvars) scheme/match mzlib/etc mzlib/trace @@ -111,15 +113,15 @@ (define (cgen/arr V X t-arr s-arr) (define (cg S T) (cgen V X S T)) (match* (t-arr s-arr) - [((arr: ts t #f #f t-thn-eff t-els-eff) - (arr: ss s #f #f s-thn-eff s-els-eff)) + [((arr: ts t #f #f '() t-thn-eff t-els-eff) + (arr: ss s #f #f '() s-thn-eff s-els-eff)) (cset-meet* (list (cgen/list V X ss ts) (cg t s) (cgen/eff/list V X t-thn-eff s-thn-eff) (cgen/eff/list V X t-els-eff s-els-eff)))] - [((arr: ts t t-rest #f t-thn-eff t-els-eff) - (arr: ss s s-rest #f s-thn-eff s-els-eff)) + [((arr: ts t t-rest #f '() t-thn-eff t-els-eff) + (arr: ss s s-rest #f '() s-thn-eff s-els-eff)) (let ([arg-mapping (cond [(and t-rest s-rest (<= (length ts) (length ss))) (cgen/list V X (cons s-rest ss) (cons t-rest (extend ss ts t-rest)))] @@ -135,8 +137,8 @@ (list arg-mapping ret-mapping (cgen/eff/list V X t-thn-eff s-thn-eff) (cgen/eff/list V X t-els-eff s-els-eff))))] - [((arr: ts t #f (cons dty dbound) t-thn-eff t-els-eff) - (arr: ss s #f #f s-thn-eff s-els-eff)) + [((arr: ts t #f (cons dty dbound) '() t-thn-eff t-els-eff) + (arr: ss s #f #f '() s-thn-eff s-els-eff)) (unless (memq dbound X) (fail! S T)) (unless (<= (length ts) (length ss)) @@ -146,10 +148,10 @@ (gensym dbound))] [new-tys (for/list ([var vars]) (substitute (make-F var) dbound dty))] - [new-cset (cgen/arr V (append vars X) (make-arr (append ts new-tys) t #f #f t-thn-eff t-els-eff) s-arr)]) + [new-cset (cgen/arr V (append vars X) (make-arr (append ts new-tys) t #f #f null t-thn-eff t-els-eff) s-arr)]) (move-vars-to-dmap new-cset dbound vars))] - [((arr: ts t #f #f t-thn-eff t-els-eff) - (arr: ss s #f (cons dty dbound) s-thn-eff s-els-eff)) + [((arr: ts t #f #f '() t-thn-eff t-els-eff) + (arr: ss s #f (cons dty dbound) '() s-thn-eff s-els-eff)) (unless (memq dbound X) (fail! S T)) (unless (<= (length ss) (length ts)) @@ -159,10 +161,10 @@ (gensym dbound))] [new-tys (for/list ([var vars]) (substitute (make-F var) dbound dty))] - [new-cset (cgen/arr V (append vars X) t-arr (make-arr (append ss new-tys) s #f #f s-thn-eff s-els-eff))]) + [new-cset (cgen/arr V (append vars X) t-arr (make-arr (append ss new-tys) s #f #f null s-thn-eff s-els-eff))]) (move-vars-to-dmap new-cset dbound vars))] - [((arr: ts t #f (cons t-dty dbound) t-thn-eff t-els-eff) - (arr: ss s #f (cons s-dty dbound) s-thn-eff s-els-eff)) + [((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff) + (arr: ss s #f (cons s-dty dbound) '() s-thn-eff s-els-eff)) (unless (= (length ts) (length ss)) (fail! S T)) ;; If we want to infer the dotted bound, then why is it in both types? @@ -175,8 +177,8 @@ (list arg-mapping darg-mapping ret-mapping (cgen/eff/list V X t-thn-eff s-thn-eff) (cgen/eff/list V X t-els-eff s-els-eff))))] - [((arr: ts t #f (cons t-dty dbound) t-thn-eff t-els-eff) - (arr: ss s #f (cons s-dty dbound*) s-thn-eff s-els-eff)) + [((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff) + (arr: ss s #f (cons s-dty dbound*) '() s-thn-eff s-els-eff)) (unless (= (length ts) (length ss)) (fail! S T)) (let* ([arg-mapping (cgen/list V X ss ts)] @@ -186,8 +188,8 @@ (list arg-mapping darg-mapping ret-mapping (cgen/eff/list V X t-thn-eff s-thn-eff) (cgen/eff/list V X t-els-eff s-els-eff))))] - [((arr: ts t t-rest #f t-thn-eff t-els-eff) - (arr: ss s #f (cons s-dty dbound) s-thn-eff s-els-eff)) + [((arr: ts t t-rest #f '() t-thn-eff t-els-eff) + (arr: ss s #f (cons s-dty dbound) '() s-thn-eff s-els-eff)) (unless (memq dbound X) (fail! S T)) (if (<= (length ts) (length ss)) @@ -205,11 +207,11 @@ [new-tys (for/list ([var vars]) (substitute (make-F var) dbound s-dty))] [new-cset (cgen/arr V (append vars X) t-arr - (make-arr (append ss new-tys) s #f (cons s-dty dbound) s-thn-eff s-els-eff))]) + (make-arr (append ss new-tys) s #f (cons s-dty dbound) null s-thn-eff s-els-eff))]) (move-vars+rest-to-dmap new-cset dbound vars)))] ;; If dotted <: starred is correct, add it below. Not sure it is. - [((arr: ts t #f (cons t-dty dbound) t-thn-eff t-els-eff) - (arr: ss s s-rest #f s-thn-eff s-els-eff)) + [((arr: ts t #f (cons t-dty dbound) '() t-thn-eff t-els-eff) + (arr: ss s s-rest #f '() s-thn-eff s-els-eff)) (unless (memq dbound X) (fail! S T)) (cond [(< (length ts) (length ss)) diff --git a/collects/typed-scheme/private/infer.ss b/collects/typed-scheme/infer/infer.ss similarity index 67% rename from collects/typed-scheme/private/infer.ss rename to collects/typed-scheme/infer/infer.ss index d860e5f551..208943a32f 100644 --- a/collects/typed-scheme/private/infer.ss +++ b/collects/typed-scheme/infer/infer.ss @@ -1,9 +1,10 @@ #lang scheme/base +(require (except-in "../utils/utils.ss" infer)) (require "infer-unit.ss" "constraints.ss" "dmap.ss" "signatures.ss" "restrict.ss" "promote-demote.ss" (only-in scheme/unit provide-signature-elements) - "unit-utils.ss") + (utils unit-utils)) (provide-signature-elements restrict^ infer^) diff --git a/collects/typed-scheme/private/promote-demote.ss b/collects/typed-scheme/infer/promote-demote.ss similarity index 80% rename from collects/typed-scheme/private/promote-demote.ss rename to collects/typed-scheme/infer/promote-demote.ss index bbb1d7b229..8705122937 100644 --- a/collects/typed-scheme/private/promote-demote.ss +++ b/collects/typed-scheme/infer/promote-demote.ss @@ -1,8 +1,9 @@ #lang scheme/unit -(require "type-effect-convenience.ss" "type-rep.ss" - "type-utils.ss" "union.ss" - "signatures.ss" +(require "../utils/utils.ss") +(require (rep type-rep) + (private type-effect-convenience union type-utils) + "signatures.ss" scheme/list) (import) @@ -26,7 +27,7 @@ [#:Param in out (make-Param (var-demote in V) (vp out))] - [#:arr dom rng rest drest thn els + [#:arr dom rng rest drest kws thn els (cond [(apply V-in? V (append thn els)) (make-arr null (Un) Univ #f null null)] @@ -35,6 +36,8 @@ (vp rng) (var-demote (car drest) V) #f + (for/list ([(kw kwt) (in-pairs kws)]) + (cons kw (var-demote kwt V))) thn els)] [else @@ -44,6 +47,8 @@ (and drest (cons (var-demote (car drest) V) (cdr drest))) + (for/list ([(kw kwt) (in-pairs kws)]) + (cons kw (var-demote kwt V))) thn els)])])) @@ -61,7 +66,7 @@ [#:Param in out (make-Param (var-promote in V) (vd out))] - [#:arr dom rng rest drest thn els + [#:arr dom rng rest drest kws thn els (cond [(apply V-in? V (append thn els)) (make-arr null (Un) Univ #f null null)] @@ -70,6 +75,8 @@ (vd rng) (var-promote (car drest) V) #f + (for/list ([(kw kwt) (in-pairs kws)]) + (cons kw (var-promote kwt V))) thn els)] [else @@ -79,5 +86,7 @@ (and drest (cons (var-promote (car drest) V) (cdr drest))) + (for/list ([(kw kwt) (in-pairs kws)]) + (cons kw (var-promote kwt V))) thn els)])])) diff --git a/collects/typed-scheme/private/restrict.ss b/collects/typed-scheme/infer/restrict.ss similarity index 90% rename from collects/typed-scheme/private/restrict.ss rename to collects/typed-scheme/infer/restrict.ss index 2c86a687b7..e13656056c 100644 --- a/collects/typed-scheme/private/restrict.ss +++ b/collects/typed-scheme/infer/restrict.ss @@ -1,8 +1,8 @@ #lang scheme/unit -(require "type-rep.ss" - "type-utils.ss" "union.ss" - "subtype.ss" "remove-intersect.ss" +(require "../utils/utils.ss") +(require (rep type-rep) + (private type-utils union remove-intersect subtype) "signatures.ss" scheme/match) diff --git a/collects/typed-scheme/infer/signatures.ss b/collects/typed-scheme/infer/signatures.ss new file mode 100644 index 0000000000..6db02b38dc --- /dev/null +++ b/collects/typed-scheme/infer/signatures.ss @@ -0,0 +1,29 @@ +#lang scheme/base +(require scheme/unit) +(provide (all-defined-out)) + +(define-signature dmap^ + (dmap-meet)) + +(define-signature promote-demote^ + (var-promote var-demote)) + +(define-signature constraints^ + (exn:infer? + fail-sym + ;; inference failure - masked before it gets to the user program + (define-syntaxes (fail!) + (syntax-rules () + [(_ s t) (raise fail-sym)])) + cset-meet cset-meet* + no-constraint + empty-cset + insert + cset-combine + c-meet)) + +(define-signature restrict^ + (restrict)) + +(define-signature infer^ + (infer infer/vararg infer/dots)) diff --git a/collects/typed-scheme/no-check.ss b/collects/typed-scheme/no-check.ss new file mode 100644 index 0000000000..470a7bed8a --- /dev/null +++ b/collects/typed-scheme/no-check.ss @@ -0,0 +1,5 @@ +#lang scheme/base + +(require "private/prims.ss") +(provide (all-from-out scheme/base) + (all-from-out "private/prims.ss")) \ No newline at end of file diff --git a/collects/typed-scheme/no-check/lang/reader.ss b/collects/typed-scheme/no-check/lang/reader.ss new file mode 100644 index 0000000000..c35cbecc78 --- /dev/null +++ b/collects/typed-scheme/no-check/lang/reader.ss @@ -0,0 +1,13 @@ +#lang scheme/base +(require (prefix-in r: "../../typed-reader.ss") + (only-in syntax/module-reader wrap-read-all)) + +(define (*read in modpath line col pos) + (wrap-read-all 'typed-scheme/no-check in r:read modpath #f line col pos)) + +(define (*read-syntax src in modpath line col pos) + (wrap-read-all + 'typed-scheme/no-check in (lambda (in) (r:read-syntax src in)) + modpath src line col pos)) + +(provide (rename-out [*read read] [*read-syntax read-syntax])) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 59708588b1..6600a1f7f2 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -3,6 +3,7 @@ ;; these are libraries providing functions we add types to that are not in scheme/base (require "extra-procs.ss" + "../utils/utils.ss" (only-in scheme/list cons? take drop add-between last filter-map) (only-in rnrs/lists-6 fold-left) '#%paramz @@ -15,13 +16,12 @@ ;; these are all for constructing the types given to variables (require (for-syntax scheme/base - "init-envs.ss" - "effect-rep.ss" - (except-in "type-rep.ss" make-arr) + (env init-envs) + (except-in (rep effect-rep type-rep) make-arr) "type-effect-convenience.ss" (only-in "type-effect-convenience.ss" [make-arr* make-arr]) "union.ss" - "tc-structs.ss")) + (typecheck tc-structs))) (define-for-syntax (initialize-others) (d-s date @@ -57,6 +57,9 @@ [qq-append qq-append-ty] [id ty] ...)))])) +(define-for-syntax (one-of/c . args) + (apply Un (map -val args))) + (define-initial-env initial-env ;; make-promise @@ -145,9 +148,13 @@ [string-append (->* null -String -String)] [open-input-string (-> -String -Input-Port)] [open-output-file - (cl-> - [(-Pathlike) -Port] - [(-Pathlike Sym) -Port])] + (->key -Pathlike + #:mode (one-of/c 'binary 'text) #f + #:exists (one-of/c 'error 'append 'update 'can-update + 'replace 'truncate + 'must-truncate 'truncate/replace) + #f + -Output-Port)] [read (cl-> [(-Port) -Sexp] [() -Sexp])] @@ -205,9 +212,7 @@ [remove* (-poly (a b) (cl-> [((-lst a) (-lst a)) (-lst a)] [((-lst a) (-lst b) (a b . -> . B)) (-lst b)]))] - - [call-with-values (-poly (a b) (-> (-> a) (-> a b) b))] - + (error (make-Function (list (make-arr null (Un)) @@ -246,7 +251,6 @@ (- (cl->* (->* (list -Integer) -Integer -Integer) (->* (list N) N N))) (max (->* (list N) N N)) (min (->* (list N) N N)) - [values (make-Poly '(a) (-> (-v a) (-v a)))] [vector-ref (make-Poly (list 'a) ((make-Vector (-v a)) N . -> . (-v a)))] [build-vector (-poly (a) (-Integer (-Integer . -> . a) . -> . (make-Vector a)))] @@ -467,7 +471,7 @@ [(-Bytes N) -Bytes] [(-Bytes N N) -Bytes])] [bytes-length (-> -Bytes N)] - [open-input-file (-> -Pathlike -Input-Port)] + [open-input-file (->key -Pathlike #:mode (Un (-val 'binary) (-val 'text)) #f -Input-Port)] [close-input-port (-> -Input-Port -Void)] [close-output-port (-> -Output-Port -Void)] [read-line (cl-> @@ -553,8 +557,11 @@ [syntax-property (-poly (a) (cl->* (-> (-Syntax a) Univ Univ (-Syntax a)) (-> (-Syntax Univ) Univ Univ)))] - [values* (-polydots (a) (null (a a) . ->... . (make-ValuesDots null a 'a)))] - [call-with-values* (-polydots (b a) ((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> . b))] + [values (-polydots (a) (null (a a) . ->... . (make-ValuesDots null a 'a)))] + [call-with-values (-polydots (b a) ((-> (make-ValuesDots null a 'a)) (null (a a) . ->... . b) . -> . b))] + + [eof (-val eof)] + [read-accept-reader (-Param B B)] ) (begin-for-syntax diff --git a/collects/typed-scheme/private/base-types.ss b/collects/typed-scheme/private/base-types.ss index cc4bb42a3d..6058fd4b9c 100644 --- a/collects/typed-scheme/private/base-types.ss +++ b/collects/typed-scheme/private/base-types.ss @@ -1,9 +1,10 @@ #lang scheme/base +(require (except-in "../utils/utils.ss" extend)) (require (for-syntax scheme/base - "init-envs.ss" - (except-in "type-rep.ss" make-arr) + (env init-envs) + (except-in (rep type-rep) make-arr) "type-effect-convenience.ss" (only-in "type-effect-convenience.ss" [make-arr* make-arr]) "union.ss")) diff --git a/collects/typed-scheme/private/extra-procs.ss b/collects/typed-scheme/private/extra-procs.ss index 83aa9c4036..b5cd5378db 100644 --- a/collects/typed-scheme/private/extra-procs.ss +++ b/collects/typed-scheme/private/extra-procs.ss @@ -1,5 +1,5 @@ #lang scheme/base -(provide assert call-with-values* values*) +(provide assert call-with-values* values* foo) (define (assert v) (unless v @@ -15,4 +15,7 @@ (car as) (map car bss)))) (define call-with-values* call-with-values) -(define values* values) \ No newline at end of file +(define values* values) + +(define (foo x #:bar [bar #f]) + bar) \ No newline at end of file diff --git a/collects/typed-scheme/private/infer-dummy.ss b/collects/typed-scheme/private/infer-dummy.ss deleted file mode 100644 index 8645a31435..0000000000 --- a/collects/typed-scheme/private/infer-dummy.ss +++ /dev/null @@ -1,7 +0,0 @@ -#lang scheme/base - -(require "type-rep.ss") - -(define infer-param (make-parameter (lambda e (error 'infer "not initialized")))) -(define (unify X S T) ((infer-param) X S T (make-Univ) null)) -(provide unify infer-param) \ No newline at end of file diff --git a/collects/typed-scheme/private/mutated-vars.ss b/collects/typed-scheme/private/mutated-vars.ss index 6e7a2c2da9..a362bd5361 100644 --- a/collects/typed-scheme/private/mutated-vars.ss +++ b/collects/typed-scheme/private/mutated-vars.ss @@ -14,12 +14,11 @@ ;; syntax -> void (define (fmv/list lstx) (for-each find-mutated-vars (syntax->list lstx))) - ;(printf "called with ~a~n" (syntax->datum form)) + ;(when (and (pair? (syntax->datum form))) (printf "called with ~a~n" (syntax->datum form))) (kernel-syntax-case* form #f (define-type-alias-internal define-typed-struct-internal require/typed-internal) ;; what we care about: set! [(set! v e) (begin - ;(printf "mutated var found: ~a~n" (syntax-e #'v)) (module-identifier-mapping-put! table #'v #t))] [(define-values (var ...) expr) (find-mutated-vars #'expr)] @@ -28,15 +27,13 @@ [(begin0 . rest) (fmv/list #'rest)] [(#%plain-lambda _ . rest) (fmv/list #'rest)] [(case-lambda (_ . rest) ...) (for-each fmv/list (syntax->list #'(rest ...)))] - [(if e1 e2) (begin (find-mutated-vars #'e1) (find-mutated-vars #'e2))] - [(if e1 e2 e3) (begin (find-mutated-vars #'e1) (find-mutated-vars #'e1) (find-mutated-vars #'e3))] - [(with-continuation-mark e1 e2 e3) (begin (find-mutated-vars #'e1) - (find-mutated-vars #'e1) - (find-mutated-vars #'e3))] + [(if . es) (fmv/list #'es)] + [(with-continuation-mark . es) (fmv/list #'es)] [(let-values ([_ e] ...) . b) (begin (fmv/list #'(e ...)) (fmv/list #'b))] [(letrec-values ([_ e] ...) . b) (begin (fmv/list #'(e ...)) - (fmv/list #'b))] + (fmv/list #'b))] + [(#%expression e) (find-mutated-vars #'e)] ;; all the other forms don't have any expression subforms (like #%top) [_ (void)])) diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index 2b92c493d6..07adfd9e17 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -2,16 +2,15 @@ (provide parse-type parse-type/id) -(require (except-in "type-rep.ss" make-arr) +(require (except-in "../utils/utils.ss" extend)) +(require (except-in (rep type-rep) make-arr) "type-effect-convenience.ss" (only-in "type-effect-convenience.ss" [make-arr* make-arr]) - "tc-utils.ss" + (utils tc-utils) "union.ss" syntax/stx - (except-in "type-environments.ss") - "type-name-env.ss" - "type-alias-env.ss" - "type-utils.ss" + (env type-environments type-name-env type-alias-env) + "type-utils.ss" scheme/match) (define enable-mu-parsing (make-parameter #t)) @@ -213,7 +212,7 @@ ;(printf "found a type name ~a~n" #'id) (make-Name #'id)] [else - (tc-error/delayed "unbound type ~a" (syntax-e #'id)) + (tc-error/delayed "unbound type name ~a" (syntax-e #'id)) Univ])] [(All . rest) (eq? (syntax-e #'All) 'All) (tc-error "All: bad syntax")] diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index ef3e7cc5a7..9068659cfd 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/collects/typed-scheme/private/prims.ss @@ -22,20 +22,20 @@ This file defines two sorts of primitives. All of them are provided into any mod (provide (all-defined-out) (rename-out [define-typed-struct define-struct:])) +(require (except-in "../utils/utils.ss" extend)) (require (for-syntax scheme/base - "type-rep.ss" + (rep type-rep) mzlib/match "parse-type.ss" syntax/struct syntax/stx - "utils.ss" - "tc-utils.ss" - "type-name-env.ss" + (utils utils tc-utils) + (env type-name-env) "type-contract.ss")) (require "require-contract.ss" - "internal-forms.ss" + (typecheck internal-forms) (except-in mzlib/contract ->) (only-in mzlib/contract [-> c->]) mzlib/struct diff --git a/collects/typed-scheme/private/remove-intersect.ss b/collects/typed-scheme/private/remove-intersect.ss index f9b273e80a..d244fb7302 100644 --- a/collects/typed-scheme/private/remove-intersect.ss +++ b/collects/typed-scheme/private/remove-intersect.ss @@ -1,7 +1,8 @@ #lang scheme/base -(require "type-rep.ss" "union.ss" "subtype.ss" - "type-utils.ss" "resolve-type.ss" "type-effect-convenience.ss" +(require (except-in "../utils/utils.ss" extend)) +(require (rep type-rep) + (private union subtype resolve-type type-effect-convenience type-utils) mzlib/plt-match mzlib/trace) (provide (rename-out [*remove remove]) overlap) diff --git a/collects/typed-scheme/private/resolve-type.ss b/collects/typed-scheme/private/resolve-type.ss index d68de69267..6526a42819 100644 --- a/collects/typed-scheme/private/resolve-type.ss +++ b/collects/typed-scheme/private/resolve-type.ss @@ -1,6 +1,7 @@ #lang scheme/base +(require "../utils/utils.ss") -(require "type-rep.ss" "type-name-env.ss" "tc-utils.ss" +(require (rep type-rep) (env type-name-env) (utils tc-utils) "type-utils.ss" mzlib/plt-match mzlib/trace) diff --git a/collects/typed-scheme/private/subtype.ss b/collects/typed-scheme/private/subtype.ss index 398fe7b226..1db8c33be8 100644 --- a/collects/typed-scheme/private/subtype.ss +++ b/collects/typed-scheme/private/subtype.ss @@ -1,12 +1,13 @@ #lang scheme/base +(require "../utils/utils.ss") -(require (except-in "type-rep.ss" sub-eff) "type-utils.ss" - "tc-utils.ss" - "effect-rep.ss" +(require (except-in (rep type-rep effect-rep) sub-eff) + (utils tc-utils) + "type-utils.ss" "type-comparison.ss" "resolve-type.ss" - "type-name-env.ss" - (only-in "infer-dummy.ss" unify) + (env type-name-env) + (only-in (infer infer-dummy) unify) mzlib/plt-match mzlib/trace) @@ -100,10 +101,13 @@ (match (list s t) ;; top for functions is above everything [(list _ (top-arr:)) A0] - [(list (arr: s1 s2 #f #f thn-eff els-eff) (arr: t1 t2 #f #f thn-eff els-eff)) - (let ([A1 (subtypes* A0 t1 s1)]) + [(list (arr: s1 s2 #f #f (list (cons kw s-kw-ty) ...) thn-eff els-eff) + (arr: t1 t2 #f #f (list (cons kw t-kw-ty) ...) thn-eff els-eff)) + (let* ([A1 (subtypes* A0 t1 s1)] + [A2 (subtypes* A1 t-kw-ty s-kw-ty)]) (subtype* A1 s2 t2))] - [(list (arr: s1 s2 s3 #f thn-eff els-eff) (arr: t1 t2 t3 #f thn-eff* els-eff*)) + [(list (arr: s1 s2 s3 #f (list (cons kw s-kw-ty) ...) thn-eff els-eff) + (arr: t1 t2 t3 #f (list (cons kw t-kw-ty) ...) thn-eff* els-eff*)) (unless (or (and (null? thn-eff*) (null? els-eff*)) (and (effects-equal? thn-eff thn-eff*) @@ -115,10 +119,11 @@ (andmap sub-eff els-eff els-eff*))) (fail! s t)) ;; either the effects have to be the same, or the supertype can't have effects - (let ([A (subtypes*/varargs A0 t1 s1 s3)]) + (let* ([A2 (subtypes*/varargs A0 t1 s1 s3)] + [A3 (subtypes* A2 t-kw-ty s-kw-ty)]) (if (not t3) - (subtype* A s2 t2) - (let ([A1 (subtype* A t3 s3)]) + (subtype* A3 s2 t2) + (let ([A1 (subtype* A3 t3 s3)]) (subtype* A1 s2 t2))))] [else (fail! s t)]))) diff --git a/collects/typed-scheme/private/type-annotation.ss b/collects/typed-scheme/private/type-annotation.ss index 1a72e73bdd..bbb8303412 100644 --- a/collects/typed-scheme/private/type-annotation.ss +++ b/collects/typed-scheme/private/type-annotation.ss @@ -1,7 +1,11 @@ #lang scheme/base -(require "type-rep.ss" "parse-type.ss" "tc-utils.ss" "subtype.ss" "utils.ss" - "type-env.ss" "type-effect-convenience.ss" "resolve-type.ss" "union.ss" +(require (except-in "../utils/utils.ss" extend)) +(require (rep type-rep) + (utils tc-utils) + (env type-env) + "parse-type.ss" "subtype.ss" + "type-effect-convenience.ss" "resolve-type.ss" "union.ss" scheme/match mzlib/trace) (provide type-annotation get-type diff --git a/collects/typed-scheme/private/type-comparison.ss b/collects/typed-scheme/private/type-comparison.ss index dab6743a78..dbc70e5f46 100644 --- a/collects/typed-scheme/private/type-comparison.ss +++ b/collects/typed-scheme/private/type-comparison.ss @@ -1,3 +1,4 @@ #lang scheme/base -(require "type-rep.ss" "type-utils.ss") +(require "../utils/utils.ss") +(require (rep type-rep) "type-utils.ss") (provide type-equal? tc-result-equal? typecontract define/fixup-contract? generate-contract-def change-contract-fixups) +(require (except-in "../utils/utils.ss" extend)) (require - "type-rep.ss" + (rep type-rep) + (typecheck internal-forms) + (utils tc-utils) + (env type-name-env) "parse-type.ss" - "utils.ss" - "type-name-env.ss" "require-contract.ss" - "internal-forms.ss" - "tc-utils.ss" "resolve-type.ss" "type-utils.ss" (only-in "type-effect-convenience.ss" Any-Syntax) @@ -80,13 +80,13 @@ (define (f a) (define-values (dom* rngs* rst) (match a - [(arr: dom (Values: rngs) #f #f _ _) + [(arr: dom (Values: rngs) #f #f '() _ _) (values (map t->c dom) (map t->c rngs) #f)] - [(arr: dom rng #f #f _ _) + [(arr: dom rng #f #f '() _ _) (values (map t->c dom) (list (t->c rng)) #f)] - [(arr: dom (Values: rngs) rst #f _ _) + [(arr: dom (Values: rngs) rst #f '() _ _) (values (map t->c dom) (map t->c rngs) (t->c rst))] - [(arr: dom rng rst #f _ _) + [(arr: dom rng rst #f '() _ _) (values (map t->c dom) (list (t->c rng)) (t->c rst))])) (with-syntax ([(dom* ...) dom*] diff --git a/collects/typed-scheme/private/type-effect-convenience.ss b/collects/typed-scheme/private/type-effect-convenience.ss index 9ae26d5479..13aa199c91 100644 --- a/collects/typed-scheme/private/type-effect-convenience.ss +++ b/collects/typed-scheme/private/type-effect-convenience.ss @@ -1,14 +1,16 @@ #lang scheme/base -(require "type-rep.ss" - "effect-rep.ss" +(require "../utils/utils.ss") + +(require (rep type-rep effect-rep) + (utils tc-utils) scheme/match "type-comparison.ss" "type-effect-printer.ss" "union.ss" "subtype.ss" "type-utils.ss" - "tc-utils.ss" scheme/promise + (for-syntax macro-debugger/stxclass/stxclass) (for-syntax scheme/base)) (provide (all-defined-out)) @@ -33,7 +35,7 @@ [(Latent-Remove-Effect: t) (make-Remove-Effect t v)] [(True-Effect:) eff] [(False-Effect:) eff] - [_ (error 'internal-tc-error "can't add var to effect ~a" eff)])) + [_ (int-err "can't add var ~a to effect ~a" v eff)])) (define-syntax (-> stx) (syntax-case* stx (:) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) @@ -78,11 +80,26 @@ [(Function: as) as])) (make-Function (map car (map funty-arities args)))) +(define-syntax (->key stx) + (syntax-parse stx + [(_ ty:expr ... ((k:keyword kty:expr opt:boolean)) ...* rng) + #'(make-Function + (list + (make-arr* (list ty ...) + rng + #f + #f + (list (make-Keyword 'k kty opt) ...) + null + null)))])) + (define make-arr* - (case-lambda [(dom rng) (make-arr* dom rng #f (list) (list))] - [(dom rng rest) (make-arr dom rng rest #f (list) (list))] - [(dom rng rest eff1 eff2) (make-arr dom rng rest #f eff1 eff2)] - [(dom rng rest drest eff1 eff2) (make-arr dom rng rest drest eff1 eff2)])) + (case-lambda [(dom rng) (make-arr dom rng #f #f null (list) (list))] + [(dom rng rest) (make-arr dom rng rest #f null (list) (list))] + [(dom rng rest eff1 eff2) (make-arr dom rng rest #f null eff1 eff2)] + [(dom rng rest drest eff1 eff2) (make-arr dom rng rest drest null eff1 eff2)] + [(dom rng rest drest kws eff1 eff2) + (make-arr dom rng rest drest (sort #:key Keyword-kw kws keywordlist #'(kw ...))) - (syntax/loc stx (tc rec-id (lambda (e) (sub-eff rec-id e)) ty [kw pats ... es] ...))] + [(tc rec-id ty clauses ...) + (syntax-case #'(clauses ...) () + [([kw pats ... es] ...) #t] + [_ #f]) + (syntax/loc stx (tc rec-id (lambda (e) (sub-eff rec-id e)) ty clauses ...))] [(tc rec-id e-rec-id ty clauses ...) (begin (map add-clause (syntax->list #'(clauses ...))) @@ -296,7 +314,7 @@ ;; necessary to avoid infinite loops [#:Union elems (*Union (remove-dups (sort (map sb elems) typelist args))) (match f-ty - [(tc-result: (Function: (list (arr: doms rngs rests drests thn-effs els-effs) ...))) + [(tc-result: (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ...))) (when (null? doms) (tc-error/expr #:return (ret (Un)) "empty case-lambda given as argument to apply")) @@ -204,7 +198,7 @@ (printf/log "Non-poly apply, ... arg\n") (ret (car rngs*))] [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] - [(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests drests thn-effs els-effs) ..1)))) + [(tc-result: (Poly: vars (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ..1)))) (let*-values ([(arg-tys) (map tc-expr/t fixed-args)] [(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))]) (tc/dots tail))]) @@ -214,7 +208,7 @@ (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) (cond [(null? doms*) (match f-ty - [(tc-result: (Poly-names: _ (Function: (list (arr: doms rngs rests drests _ _) ..1)))) + [(tc-result: (Poly-names: _ (Function: (list (arr: doms rngs rests drests '() _ _) ..1)))) (tc-error/expr #:return (ret (Un)) (string-append "Bad arguments to polymorphic function in apply:~n" @@ -259,14 +253,14 @@ (tc-error/expr #:return (ret (Un)) "Function has no cases")] [(tc-result: (PolyDots: (and vars (list fixed-vars ... dotted-var)) - (Function: (list (arr: doms rngs rests drests thn-effs els-effs) ..1)))) + (Function: (list (arr: doms rngs rests drests '() thn-effs els-effs) ..1)))) (let*-values ([(arg-tys) (map tc-expr/t fixed-args)] [(tail-ty tail-bound) (with-handlers ([exn:fail:syntax? (lambda _ (values (tc-expr/t tail) #f))]) (tc/dots tail))]) (let loop ([doms* doms] [rngs* rngs] [rests* rests] [drests* drests]) (cond [(null? doms*) (match f-ty - [(tc-result: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests _ _) ..1)))) + [(tc-result: (PolyDots-names: _ (Function: (list (arr: doms rngs rests drests '() _ _) ..1)))) (tc-error/expr #:return (ret (Un)) (string-append "Bad arguments to polymorphic function in apply:~n" @@ -378,8 +372,8 @@ (define (poly-fail t argtypes #:name [name #f]) (match t - [(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests _ _) ...))) - (PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests _ _) ...)))) + [(or (Poly-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...))) + (PolyDots-names: msg-vars (Function: (list (arr: msg-doms msg-rngs msg-rests msg-drests '() _ _) ...)))) (let ([fcn-string (if name (format "function ~a (over ~~a)" (syntax->datum name)) "function over ~a")]) @@ -429,7 +423,8 @@ "Wrong number of arguments to parameter - expected 0 or 1, got ~a" (length argtypes))])] ;; single clause functions - [(tc-result: (and t (Function: (list (arr: dom rng rest #f latent-thn-effs latent-els-effs)))) + ;; FIXME - error on non-optional keywords + [(tc-result: (and t (Function: (list (arr: dom rng rest #f _ latent-thn-effs latent-els-effs)))) thn-eff els-eff) (let-values ([(thn-eff els-eff) (tc-args argtypes arg-thn-effs arg-els-effs dom rest @@ -437,7 +432,7 @@ (syntax->list args))]) (ret rng thn-eff els-eff))] ;; non-polymorphic case-lambda functions - [(tc-result: (and t (Function: (list (arr: doms rngs rests (and drests #f) latent-thn-effs latent-els-effs) ..1))) + [(tc-result: (and t (Function: (list (arr: doms rngs rests (and drests #f) '() latent-thn-effs latent-els-effs) ..1))) thn-eff els-eff) (let loop ([doms* doms] [rngs rngs] [rests* rests]) (cond [(null? doms*) @@ -453,19 +448,19 @@ ;; simple polymorphic functions, no rest arguments [(tc-result: (and t (or (Poly: vars - (Function: (list (arr: doms rngs (and rests #f) (and drests #f) thn-effs els-effs) ...))) + (Function: (list (arr: doms rngs (and rests #f) (and drests #f) '() thn-effs els-effs) ...))) (PolyDots: (list vars ... _) - (Function: (list (arr: doms rngs (and rests #f) (and drests #f) thn-effs els-effs) ...)))))) + (Function: (list (arr: doms rngs (and rests #f) (and drests #f) '() thn-effs els-effs) ...)))))) (handle-clauses (doms rngs) f-stx (lambda (dom _) (= (length dom) (length argtypes))) (lambda (dom rng) (infer (fv/list (cons rng dom)) argtypes dom rng (fv rng) expected)) t argtypes expected)] ;; polymorphic varargs [(tc-result: (and t - (or (Poly: vars (Function: (list (arr: doms rngs rests (and drests #f) thn-effs els-effs) ...))) + (or (Poly: vars (Function: (list (arr: doms rngs rests (and drests #f) '() thn-effs els-effs) ...))) ;; we want to infer the dotted-var here as well, and we don't use these separately ;; so we can just use "vars" instead of (list fixed-vars ... dotted-var) - (PolyDots: vars (Function: (list (arr: doms rngs rests (and drests #f) thn-effs els-effs) ...)))))) + (PolyDots: vars (Function: (list (arr: doms rngs rests (and drests #f) '() thn-effs els-effs) ...)))))) (printf/log "Polymorphic varargs function application (~a)\n" (syntax->datum f-stx)) (handle-clauses (doms rests rngs) f-stx (lambda (dom rest rng) (<= (length dom) (length argtypes))) @@ -474,7 +469,7 @@ ;; polymorphic ... type [(tc-result: (and t (PolyDots: (and vars (list fixed-vars ... dotted-var)) - (Function: (list (arr: doms rngs (and #f rests) (cons dtys dbounds) thn-effs els-effs) ...))))) + (Function: (list (arr: doms rngs (and #f rests) (cons dtys dbounds) '() thn-effs els-effs) ...))))) (printf/log "Polymorphic ... function application (~a)\n" (syntax->datum f-stx)) (handle-clauses (doms dtys dbounds rngs) f-stx (lambda (dom dty dbound rng) (and (<= (length dom) (length argtypes)) @@ -566,6 +561,47 @@ [(tc-result: t) (tc-error/expr #:return (ret (Un)) "expected a class value for object creation, got: ~a" t)])))) +(define (tc-keywords form arities kws kw-args pos-args expected) + (match arities + [(list (arr: dom rng rest #f ktys _ _)) + ;; assumes that everything is in sorted order + (let loop ([actual-kws kws] + [actuals (map tc-expr/t (syntax->list kw-args))] + [formals ktys]) + (match* (actual-kws formals) + [('() '()) + (void)] + [(_ '()) + (tc-error/expr #:return (ret (Un)) + "Unexpected keyword argument ~a" (car actual-kws))] + [('() (cons fst rst)) + (match fst + [(Keyword: k _ #t) + (tc-error/expr #:return (ret (Un)) + "Missing keyword argument ~a" k)] + [_ (loop actual-kws actuals rst)])] + [((cons k kws-rest) (cons (Keyword: k* t req?) form-rest)) + (cond [(eq? k k*) ;; we have a match + (unless (subtype (car actuals) t) + (tc-error/delayed + "Wrong function argument type, expected ~a, got ~a for keyword argument ~a" + t (car actuals) k)) + (loop kws-rest (cdr actuals) form-rest)] + [req? ;; this keyword argument was required + (tc-error/delayed "Missing keyword argument ~a" k*) + (loop kws-rest (cdr actuals) form-rest)] + [else ;; otherwise, ignore this formal param, and continue + (loop actual-kws actuals form-rest)])])) + (tc/funapp (car (syntax-e form)) kw-args (ret (make-Function arities)) (map tc-expr (syntax->list pos-args)) expected)] + [_ (int-err "case-lambda w/ keywords not supported")])) + + +(define (type->list t) + (match t + [(Pair: (Value: (? keyword? k)) b) (cons k (type->list b))] + [(Value: '()) null] + [_ (int-err "bad value in type->list: ~a" t)])) + (define (tc/app/internal form expected) (kernel-syntax-case* form #f (values apply not list list* call-with-values do-make-object make-object cons @@ -585,7 +621,7 @@ [(Values: ts) ts] [_ (list t)])) (match prod-t - [(Function: (list (arr: (list) vals _ #f _ _))) + [(Function: (list (arr: (list) vals _ #f '() _ _))) (tc/funapp #'con #'prod (tc-expr #'con) (map ret (values-ty->list vals)) expected)] [_ (tc-error/expr #:return (ret (Un)) "First argument to call with values must be a function that can accept no arguments, got: ~a" @@ -621,11 +657,23 @@ [(tc-result: t thn-eff els-eff) (ret B (map var->type-eff els-eff) (map var->type-eff thn-eff))])] ;; special case for `apply' - [(#%plain-app apply f . args) (tc/apply #'f #'args)] + [(#%plain-app apply f . args) (tc/apply #'f #'args)] + ;; special case for keywords + [(#%plain-app + (#%plain-app kpe kws num fn) + kw-list + (#%plain-app list . kw-arg-list) + . pos-args) + (eq? (syntax-e #'kpe) 'keyword-procedure-extract) + (match (tc-expr #'fn) + [(tc-result: (Function: arities)) + (tc-keywords form arities (type->list (tc-expr/t #'kws)) #'kw-arg-list #'pos-args expected)] + [t (tc-error/expr #:return (ret (Un)) + "Cannot apply expression of type ~a, since it is not a function type" t)])] ;; even more special case for match [(#%plain-app (letrec-values ([(lp) (#%plain-lambda args . body)]) lp*) . actuals) (and expected (not (andmap type-annotation (syntax->list #'args))) (free-identifier=? #'lp #'lp*)) - (let-loop-check #'form #'lp #'actuals #'args #'body expected)] + (let-loop-check form #'lp #'actuals #'args #'body expected)] ;; or/andmap of ... argument [(#%plain-app or/andmap f arg) (and diff --git a/collects/typed-scheme/private/tc-dots-unit.ss b/collects/typed-scheme/typecheck/tc-dots-unit.ss similarity index 89% rename from collects/typed-scheme/private/tc-dots-unit.ss rename to collects/typed-scheme/typecheck/tc-dots-unit.ss index 803ef905db..aa2c7c17b1 100644 --- a/collects/typed-scheme/private/tc-dots-unit.ss +++ b/collects/typed-scheme/typecheck/tc-dots-unit.ss @@ -1,10 +1,11 @@ #lang scheme/unit +(require (except-in "../utils/utils.ss" extend)) (require "signatures.ss" - "tc-utils.ss" - "type-environments.ss" - "type-utils.ss" - "type-rep.ss" + (utils tc-utils) + (env type-environments) + (private type-utils) + (rep type-rep) syntax/kerncase scheme/match) diff --git a/collects/typed-scheme/private/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss similarity index 95% rename from collects/typed-scheme/private/tc-expr-unit.ss rename to collects/typed-scheme/typecheck/tc-expr-unit.ss index feb7129a36..c61bbd3d9f 100644 --- a/collects/typed-scheme/private/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -1,21 +1,15 @@ #lang scheme/unit +(require (rename-in "../utils/utils.ss" [private r:private])) (require syntax/kerncase scheme/match "signatures.ss" - "type-utils.ss" - "utils.ss" ;; doesn't need tests - "type-rep.ss" ;; doesn't need tests - "type-effect-convenience.ss" ;; maybe needs tests - "union.ss" - "subtype.ss" ;; has tests - "parse-type.ss" ;; has tests - "tc-utils.ss" ;; doesn't need tests - "lexical-env.ss" ;; maybe needs tests - "type-annotation.ss" ;; has tests - "effect-rep.ss" - (only-in "type-environments.ss" lookup current-tvars extend-env) + (r:private type-utils type-effect-convenience union subtype parse-type type-annotation) + (rep type-rep effect-rep) + (utils tc-utils) + (env lexical-env) + (only-in (env type-environments) lookup current-tvars extend-env) scheme/private/class-internal (only-in srfi/1 split-at)) @@ -41,7 +35,7 @@ [(null? v) (-val null)] [(symbol? v) (-val v)] [(string? v) -String] - [(keyword? v) -Keyword] + [(keyword? v) (-val v)] [(bytes? v) -Bytes] [(list? v) (-Tuple (map tc-literal v))] [(vector? v) (make-Vector (types-of-literals (vector->list v)))] @@ -101,7 +95,8 @@ ;; typecheck an expression, but throw away the effect ;; tc-expr/t : Expr -> Type (define (tc-expr/t e) (match (tc-expr e) - [(tc-result: t) t])) + [(tc-result: t) t] + [t (int-err "tc-expr returned ~a, not a tc-result, for ~a" t (syntax->datum e))])) (define (tc-expr/check/t e t) (match (tc-expr/check e t) diff --git a/collects/typed-scheme/private/tc-if-unit.ss b/collects/typed-scheme/typecheck/tc-if-unit.ss similarity index 95% rename from collects/typed-scheme/private/tc-if-unit.ss rename to collects/typed-scheme/typecheck/tc-if-unit.ss index f59b19fe60..e1d75c236c 100644 --- a/collects/typed-scheme/private/tc-if-unit.ss +++ b/collects/typed-scheme/typecheck/tc-if-unit.ss @@ -1,20 +1,15 @@ #lang scheme/unit -(require "planet-requires.ss" +(require (rename-in "../utils/utils.ss" [infer r:infer])) +(require (utils planet-requires) "signatures.ss" - "type-rep.ss" ;; doesn't need tests - "type-effect-convenience.ss" ;; maybe needs tests - "lexical-env.ss" ;; maybe needs tests - "effect-rep.ss" - "mutated-vars.ss" - "subtype.ss" - (only-in "remove-intersect.ss" + (rep type-rep effect-rep) + (private type-effect-convenience subtype union type-utils type-comparison mutated-vars) + (env lexical-env) + (only-in (private remove-intersect) [remove *remove]) - "infer.ss" - "union.ss" - "type-utils.ss" - "tc-utils.ss" - "type-comparison.ss" + (r:infer infer) + (utils tc-utils) syntax/kerncase mzlib/trace mzlib/plt-match) diff --git a/collects/typed-scheme/private/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss similarity index 96% rename from collects/typed-scheme/private/tc-lambda-unit.ss rename to collects/typed-scheme/typecheck/tc-lambda-unit.ss index d91531536e..962c480e05 100644 --- a/collects/typed-scheme/private/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -1,20 +1,15 @@ #lang scheme/unit +(require (rename-in "../utils/utils.ss" [infer r:infer] [extend r:extend])) (require "signatures.ss" mzlib/trace scheme/list - (except-in "type-rep.ss" make-arr) ;; doesn't need tests - "type-effect-convenience.ss" ;; maybe needs tests - "type-environments.ss" ;; doesn't need tests - "lexical-env.ss" ;; maybe needs tests - "type-annotation.ss" ;; has tests - (except-in "utils.ss" extend) - "type-utils.ss" - "effect-rep.ss" - "tc-utils.ss" - "union.ss" + (except-in (rep type-rep effect-rep) make-arr) ;; doesn't need tests + (private type-effect-convenience type-annotation union type-utils) + (env type-environments lexical-env) + (utils tc-utils) mzlib/plt-match - (only-in "type-effect-convenience.ss" [make-arr* make-arr])) + (only-in (private type-effect-convenience) [make-arr* make-arr])) (require (for-template scheme/base "internal-forms.ss")) (import tc-expr^) @@ -180,7 +175,7 @@ (let loop ([expected expected]) (match expected [(Mu: _ _) (loop (unfold expected))] - [(Function: (list (arr: argss rets rests drests _ _) ...)) + [(Function: (list (arr: argss rets rests drests '() _ _) ...)) (for ([args argss] [ret rets] [rest rests] [drest drests]) (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) args ret rest drest)) expected] diff --git a/collects/typed-scheme/private/tc-let-unit.ss b/collects/typed-scheme/typecheck/tc-let-unit.ss similarity index 96% rename from collects/typed-scheme/private/tc-let-unit.ss rename to collects/typed-scheme/typecheck/tc-let-unit.ss index eb29285264..9bf2bf3fa7 100644 --- a/collects/typed-scheme/private/tc-let-unit.ss +++ b/collects/typed-scheme/typecheck/tc-let-unit.ss @@ -1,14 +1,9 @@ #lang scheme/unit +(require (rename-in "../utils/utils.ss" [infer r:infer])) (require "signatures.ss" - "type-effect-convenience.ss" - "lexical-env.ss" - "type-annotation.ss" - "type-alias-env.ss" - "type-env.ss" - "parse-type.ss" - "utils.ss" - "type-utils.ss" + (private type-effect-convenience type-annotation parse-type type-utils) + (env lexical-env type-alias-env type-env) syntax/free-vars mzlib/trace scheme/match diff --git a/collects/typed-scheme/private/tc-structs.ss b/collects/typed-scheme/typecheck/tc-structs.ss similarity index 95% rename from collects/typed-scheme/private/tc-structs.ss rename to collects/typed-scheme/typecheck/tc-structs.ss index 23c8a43038..86233c0df2 100644 --- a/collects/typed-scheme/private/tc-structs.ss +++ b/collects/typed-scheme/typecheck/tc-structs.ss @@ -1,15 +1,12 @@ #lang scheme/base -(require "type-rep.ss" ;; doesn't need tests - "type-effect-convenience.ss" ;; maybe needs tests - "type-env.ss" ;; maybe needs tests - "type-utils.ss" - "parse-type.ss" ;; has tests - "type-environments.ss" ;; doesn't need tests - "type-name-env.ss" ;; maybe needs tests - "union.ss" - "tc-utils.ss" - "resolve-type.ss" +(require (except-in "../utils/utils.ss" extend)) +(require (rep type-rep) + (private type-effect-convenience + type-utils parse-type + union resolve-type) + (env type-env type-environments type-name-env) + (utils tc-utils) "def-binding.ss" syntax/kerncase syntax/struct diff --git a/collects/typed-scheme/private/tc-toplevel.ss b/collects/typed-scheme/typecheck/tc-toplevel.ss similarity index 94% rename from collects/typed-scheme/private/tc-toplevel.ss rename to collects/typed-scheme/typecheck/tc-toplevel.ss index 23b3614c57..5f2d36f25b 100644 --- a/collects/typed-scheme/private/tc-toplevel.ss +++ b/collects/typed-scheme/typecheck/tc-toplevel.ss @@ -1,26 +1,17 @@ #lang scheme/unit +(require (rename-in "../utils/utils.ss" [infer r:infer])) (require syntax/kerncase mzlib/etc scheme/match "signatures.ss" "tc-structs.ss" - "type-utils.ss" - "utils.ss" ;; doesn't need tests - "type-effect-convenience.ss" ;; maybe needs tests - "internal-forms.ss" ;; doesn't need tests - "type-env.ss" ;; maybe needs tests - "parse-type.ss" ;; has tests - "tc-utils.ss" ;; doesn't need tests - "type-annotation.ss" ;; has tests - "type-name-env.ss" ;; maybe needs tests - "init-envs.ss" - "mutated-vars.ss" + (private type-utils type-effect-convenience parse-type type-annotation mutated-vars type-contract) + (env type-env init-envs type-name-env type-alias-env) + (utils tc-utils) + "provide-handling.ss" "def-binding.ss" - "provide-handling.ss" - "type-alias-env.ss" - "type-contract.ss" (for-template "internal-forms.ss" mzlib/contract diff --git a/collects/typed-scheme/private/typechecker.ss b/collects/typed-scheme/typecheck/typechecker.ss similarity index 89% rename from collects/typed-scheme/private/typechecker.ss rename to collects/typed-scheme/typecheck/typechecker.ss index 3ec16bcfcf..ed935ff901 100644 --- a/collects/typed-scheme/private/typechecker.ss +++ b/collects/typed-scheme/typecheck/typechecker.ss @@ -1,6 +1,7 @@ #lang scheme/base -(require "unit-utils.ss" +(require "../utils/utils.ss") +(require (utils unit-utils) mzlib/trace (only-in scheme/unit provide-signature-elements) "signatures.ss" "tc-toplevel.ss" diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index 19c9c9cb7d..0bcfc701b0 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -1,22 +1,18 @@ #lang scheme/base -(require "private/base-env.ss" - "private/base-types.ss" +(require (rename-in "utils/utils.ss" [infer r:infer])) + +(require (private base-env base-types) (for-syntax scheme/base - "private/type-utils.ss" - "private/typechecker.ss" - "private/type-rep.ss" - "private/provide-handling.ss" - "private/type-environments.ss" - "private/tc-utils.ss" - "private/type-name-env.ss" - "private/type-alias-env.ss" - (except-in "private/utils.ss" extend) - (only-in "private/infer-dummy.ss" infer-param) - "private/infer.ss" - "private/type-effect-convenience.ss" - "private/type-contract.ss" + (private type-utils type-contract type-effect-convenience) + (typecheck typechecker provide-handling) + (env type-environments type-name-env type-alias-env) + (r:infer infer) + (utils tc-utils) + (rep type-rep) + (except-in (utils utils) infer extend) + (only-in (r:infer infer-dummy) infer-param) scheme/nest syntax/kerncase scheme/match)) @@ -31,7 +27,7 @@ (provide (rename-out [module-begin #%module-begin] [top-interaction #%top-interaction] [#%plain-lambda lambda] - [#%plain-app #%app] + [#%app #%app] [require require])) (define-for-syntax catch-errors? #f) diff --git a/collects/typed-scheme/private/planet-requires.ss b/collects/typed-scheme/utils/planet-requires.ss similarity index 100% rename from collects/typed-scheme/private/planet-requires.ss rename to collects/typed-scheme/utils/planet-requires.ss diff --git a/collects/typed-scheme/private/syntax-traversal.ss b/collects/typed-scheme/utils/syntax-traversal.ss similarity index 100% rename from collects/typed-scheme/private/syntax-traversal.ss rename to collects/typed-scheme/utils/syntax-traversal.ss diff --git a/collects/typed-scheme/private/tables.ss b/collects/typed-scheme/utils/tables.ss similarity index 100% rename from collects/typed-scheme/private/tables.ss rename to collects/typed-scheme/utils/tables.ss diff --git a/collects/typed-scheme/private/tc-utils.ss b/collects/typed-scheme/utils/tc-utils.ss similarity index 97% rename from collects/typed-scheme/private/tc-utils.ss rename to collects/typed-scheme/utils/tc-utils.ss index 69709e3e46..132b220612 100644 --- a/collects/typed-scheme/private/tc-utils.ss +++ b/collects/typed-scheme/utils/tc-utils.ss @@ -70,12 +70,12 @@ (unless (null? stxs) (raise-typecheck-error (format "Summary: ~a errors encountered" (length stxs)) (apply append stxs))))])) -(define delay-errors? (make-parameter #t)) +(define delay-errors? (make-parameter #f)) (define (tc-error/delayed msg #:stx [stx* (current-orig-stx)] . rest) (let ([stx (locate-stx stx*)]) (unless (syntax? stx) - (error "syntax was not syntax" stx (syntax->datum stx*))) + (int-err "erroneous syntax was not a syntax object: ~a ~a" stx (syntax->datum stx*))) (if (delay-errors?) (set! delayed-errors (cons (make-err (apply format msg rest) (list stx)) delayed-errors)) (raise-typecheck-error (apply format msg rest) (list stx))))) diff --git a/collects/typed-scheme/private/unit-utils.ss b/collects/typed-scheme/utils/unit-utils.ss similarity index 100% rename from collects/typed-scheme/private/unit-utils.ss rename to collects/typed-scheme/utils/unit-utils.ss diff --git a/collects/typed-scheme/private/utils.ss b/collects/typed-scheme/utils/utils.ss similarity index 82% rename from collects/typed-scheme/private/utils.ss rename to collects/typed-scheme/utils/utils.ss index 80c3f8023d..6ca8a6a901 100644 --- a/collects/typed-scheme/private/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -2,6 +2,7 @@ (require (for-syntax scheme/base) mzlib/plt-match + scheme/require-syntax mzlib/struct) (provide with-syntax* syntax-map start-timing do-time reverse-begin printf/log @@ -16,7 +17,40 @@ in-list-forever extend debug - in-syntax) + in-syntax + ;; require macros + rep utils typecheck infer env private) + +(define-syntax (define-requirer stx) + (syntax-case stx () + [(_ nm) + #`(... + (define-require-syntax nm + (lambda (stx) + (syntax-case stx () + [(_ id ...) + (andmap identifier? (syntax->list #'(id ...))) + (with-syntax ([(id* ...) + (map (lambda (id) + (datum->syntax + id + (string->symbol + (string-append + "typed-scheme/" + #,(symbol->string (syntax-e #'nm)) + "/" + (symbol->string (syntax-e id)))) + id id)) + (syntax->list #'(id ...)))]) + (syntax/loc stx (combine-in id* ...)))]))))])) + + +(define-requirer rep) +(define-requirer infer) +(define-requirer typecheck) +(define-requirer utils) +(define-requirer env) +(define-requirer private) (define-sequence-syntax in-syntax (lambda () #'syntax->list) diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index 7e029962c4..671bf1859d 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@