From ae2d69720cc64c7398ba5991ff33f00ceb8e593f Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 11 Sep 2008 22:21:45 +0000 Subject: [PATCH] svn merge -r11644:11643 . Yeah, these trunk merges will eventually come back. svn: r11655 --- .../tests/typed-scheme/fail/values-dots.ss | 4 +- .../tests/typed-scheme/succeed/nested-poly.ss | 2 +- .../tests/typed-scheme/succeed/values-dots.ss | 8 +- .../typed-scheme/unit-tests/all-tests.ss | 2 +- .../typed-scheme/unit-tests/infer-tests.ss | 7 +- .../typed-scheme/unit-tests/module-tests.ss | 2 +- .../unit-tests/parse-type-tests.ss | 8 +- .../unit-tests/remove-intersect-tests.ss | 5 +- .../typed-scheme/unit-tests/subst-tests.ss | 4 +- .../typed-scheme/unit-tests/subtype-tests.ss | 8 +- .../typed-scheme/unit-tests/test-utils.ss | 19 ++- .../unit-tests/type-annotation-test.ss | 6 +- .../unit-tests/type-equal-tests.ss | 3 +- .../unit-tests/typecheck-tests.ss | 18 ++- collects/typed-scheme/infer/infer-dummy.ss | 8 -- collects/typed-scheme/infer/signatures.ss | 29 ----- collects/typed-scheme/no-check.ss | 5 - collects/typed-scheme/no-check/lang/reader.ss | 13 --- collects/typed-scheme/private/base-env.ss | 35 +++--- collects/typed-scheme/private/base-types.ss | 5 +- .../check-subforms-unit.ss | 13 ++- .../{infer => private}/constraint-structs.ss | 3 +- .../{infer => private}/constraints.ss | 7 +- .../{typecheck => private}/def-binding.ss | 0 .../{typecheck => private}/defstruct-unit.ss | 0 .../typed-scheme/{infer => private}/dmap.ss | 4 +- .../{rep => private}/effect-rep.ss | 0 collects/typed-scheme/private/extra-procs.ss | 7 +- .../{rep => private}/free-variance.ss | 7 +- collects/typed-scheme/private/infer-dummy.ss | 7 ++ .../{infer => private}/infer-unit.ss | 52 ++++----- .../typed-scheme/{infer => private}/infer.ss | 3 +- .../{env => private}/init-envs.ss | 15 +-- .../{typecheck => private}/internal-forms.ss | 0 .../{rep => private}/interning.ss | 0 .../{env => private}/lexical-env.ss | 8 +- collects/typed-scheme/private/mutated-vars.ss | 13 ++- collects/typed-scheme/private/parse-type.ss | 13 ++- .../{utils => private}/planet-requires.ss | 0 collects/typed-scheme/private/prims.ss | 10 +- .../{infer => private}/promote-demote.ss | 19 +-- .../provide-handling.ss | 7 +- .../typed-scheme/private/remove-intersect.ss | 5 +- .../{rep => private}/rep-utils.ss | 10 +- collects/typed-scheme/private/resolve-type.ss | 3 +- .../{infer => private}/restrict.ss | 6 +- .../{typecheck => private}/signatures.ss | 32 ++++- collects/typed-scheme/private/subtype.ss | 27 ++--- .../{utils => private}/syntax-traversal.ss | 0 .../typed-scheme/{utils => private}/tables.ss | 0 .../{typecheck => private}/tc-app-unit.ss | 110 +++++------------- .../{typecheck => private}/tc-dots-unit.ss | 9 +- .../{typecheck => private}/tc-expr-unit.ss | 23 ++-- .../{typecheck => private}/tc-if-unit.ss | 21 ++-- .../{typecheck => private}/tc-lambda-unit.ss | 19 +-- .../{typecheck => private}/tc-let-unit.ss | 11 +- .../{typecheck => private}/tc-structs.ss | 17 +-- .../{typecheck => private}/tc-toplevel.ss | 19 ++- .../{utils => private}/tc-utils.ss | 4 +- .../{env => private}/type-alias-env.ss | 3 +- .../typed-scheme/private/type-annotation.ss | 8 +- .../typed-scheme/private/type-comparison.ss | 3 +- .../typed-scheme/private/type-contract.ss | 18 +-- .../private/type-effect-convenience.ss | 33 ++---- .../private/type-effect-printer.ss | 16 +-- .../typed-scheme/{env => private}/type-env.ss | 4 +- .../{env => private}/type-environments.ss | 3 +- .../{env => private}/type-name-env.ss | 5 +- .../typed-scheme/{rep => private}/type-rep.ss | 46 ++------ collects/typed-scheme/private/type-utils.ss | 24 ++-- .../{typecheck => private}/typechecker.ss | 3 +- collects/typed-scheme/private/union.ss | 8 +- .../{utils => private}/unit-utils.ss | 0 .../typed-scheme/{utils => private}/utils.ss | 36 +----- collects/typed-scheme/typed-scheme.ss | 28 +++-- 75 files changed, 374 insertions(+), 559 deletions(-) delete mode 100644 collects/typed-scheme/infer/infer-dummy.ss delete mode 100644 collects/typed-scheme/infer/signatures.ss delete mode 100644 collects/typed-scheme/no-check.ss delete mode 100644 collects/typed-scheme/no-check/lang/reader.ss rename collects/typed-scheme/{typecheck => private}/check-subforms-unit.ss (89%) rename collects/typed-scheme/{infer => private}/constraint-structs.ss (94%) rename collects/typed-scheme/{infer => private}/constraints.ss (94%) rename collects/typed-scheme/{typecheck => private}/def-binding.ss (100%) rename collects/typed-scheme/{typecheck => private}/defstruct-unit.ss (100%) rename collects/typed-scheme/{infer => private}/dmap.ss (92%) rename collects/typed-scheme/{rep => private}/effect-rep.ss (100%) rename collects/typed-scheme/{rep => private}/free-variance.ss (91%) create mode 100644 collects/typed-scheme/private/infer-dummy.ss rename collects/typed-scheme/{infer => private}/infer-unit.ss (92%) rename collects/typed-scheme/{infer => private}/infer.ss (67%) rename collects/typed-scheme/{env => private}/init-envs.ss (90%) rename collects/typed-scheme/{typecheck => private}/internal-forms.ss (100%) rename collects/typed-scheme/{rep => private}/interning.ss (100%) rename collects/typed-scheme/{env => private}/lexical-env.ss (90%) rename collects/typed-scheme/{utils => private}/planet-requires.ss (100%) rename collects/typed-scheme/{infer => private}/promote-demote.ss (80%) rename collects/typed-scheme/{typecheck => private}/provide-handling.ss (96%) rename collects/typed-scheme/{rep => private}/rep-utils.ss (96%) rename collects/typed-scheme/{infer => private}/restrict.ss (90%) rename collects/typed-scheme/{typecheck => private}/signatures.ss (56%) rename collects/typed-scheme/{utils => private}/syntax-traversal.ss (100%) rename collects/typed-scheme/{utils => private}/tables.ss (100%) rename collects/typed-scheme/{typecheck => private}/tc-app-unit.ss (90%) rename collects/typed-scheme/{typecheck => private}/tc-dots-unit.ss (89%) rename collects/typed-scheme/{typecheck => private}/tc-expr-unit.ss (95%) rename collects/typed-scheme/{typecheck => private}/tc-if-unit.ss (95%) rename collects/typed-scheme/{typecheck => private}/tc-lambda-unit.ss (96%) rename collects/typed-scheme/{typecheck => private}/tc-let-unit.ss (96%) rename collects/typed-scheme/{typecheck => private}/tc-structs.ss (95%) rename collects/typed-scheme/{typecheck => private}/tc-toplevel.ss (94%) rename collects/typed-scheme/{utils => private}/tc-utils.ss (97%) rename collects/typed-scheme/{env => private}/type-alias-env.ss (96%) rename collects/typed-scheme/{env => private}/type-env.ss (95%) rename collects/typed-scheme/{env => private}/type-environments.ss (96%) rename collects/typed-scheme/{env => private}/type-name-env.ss (93%) rename collects/typed-scheme/{rep => private}/type-rep.ss (92%) rename collects/typed-scheme/{typecheck => private}/typechecker.ss (89%) rename collects/typed-scheme/{utils => private}/unit-utils.ss (100%) rename collects/typed-scheme/{utils => private}/utils.ss (82%) diff --git a/collects/tests/typed-scheme/fail/values-dots.ss b/collects/tests/typed-scheme/fail/values-dots.ss index f92743faf3..6c08fff545 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 ac8bb3cd8c..785ee9a5df 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 1c853f50b0..0078526faa 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 1fe728d05b..aca0a4d12c 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 (utils planet-requires) (r:infer infer infer-dummy)) +(require (private planet-requires 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 aef624b748..f1d5e22b0d 100644 --- a/collects/tests/typed-scheme/unit-tests/infer-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/infer-tests.ss @@ -1,10 +1,7 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base)) -(require (utils planet-requires) - (rep type-rep) - (r:infer infer) - (private type-effect-convenience union type-utils) - (prefix-in table: (utils tables))) +(require (private planet-requires type-effect-convenience type-rep union infer type-utils) + (prefix-in table: (private 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 490c1c2a89..51406fb008 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 (utils planet-requires)) +(require (private 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 fedf84fb81..aa3882fd38 100644 --- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss @@ -1,10 +1,8 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base)) -(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 (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 (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 20da5c73c3..ca83402b66 100644 --- a/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/remove-intersect-tests.ss @@ -1,9 +1,6 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base)) -(require (rep type-rep) - (utils planet-requires) - (r:infer infer) - (private type-effect-convenience remove-intersect subtype union)) +(require (private type-rep type-effect-convenience planet-requires remove-intersect subtype union infer)) (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 10a35fc98a..6c89d4ef6f 100644 --- a/collects/tests/typed-scheme/unit-tests/subst-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subst-tests.ss @@ -1,9 +1,7 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base)) -(require (utils planet-requires) - (rep type-rep) - (private type-utils type-effect-convenience)) +(require (private planet-requires type-utils type-effect-convenience type-rep)) (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 83bb3e9a51..f4bc99125d 100644 --- a/collects/tests/typed-scheme/unit-tests/subtype-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/subtype-tests.ss @@ -2,12 +2,8 @@ (require "test-utils.ss") -(require (private subtype type-effect-convenience union) - (rep type-rep) - (utils planet-requires) - (env init-envs type-environments) - (r:infer infer infer-dummy)) - +(require (private subtype type-rep type-effect-convenience + planet-requires init-envs type-environments union 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 b160cacdf9..f5c848fa04 100644 --- a/collects/tests/typed-scheme/unit-tests/test-utils.ss +++ b/collects/tests/typed-scheme/unit-tests/test-utils.ss @@ -3,12 +3,25 @@ (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 167db51eb7..80e471b00c 100644 --- a/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss +++ b/collects/tests/typed-scheme/unit-tests/type-annotation-test.ss @@ -1,10 +1,8 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base)) -(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 (private planet-requires type-annotation tc-utils type-rep type-effect-convenience type-environments + parse-type init-envs type-name-env)) (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 899b8e1e97..6488d47b16 100644 --- a/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/type-equal-tests.ss @@ -1,8 +1,7 @@ #lang scheme/base (require "test-utils.ss" (for-syntax scheme/base)) -(require (utils planet-requires) (rep type-rep) - (private type-comparison type-effect-convenience union subtype)) +(require (private planet-requires type-rep 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 fee35aa2fc..a5263dd32b 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -3,16 +3,14 @@ (require "test-utils.ss" (for-syntax scheme/base) (for-template scheme/base)) -(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 base-env)) -(require (for-syntax (utils tc-utils) - (typecheck typechecker) - (env type-env) - (private base-env)) +(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)) (for-template (private base-env base-types))) (require (schemeunit)) @@ -671,7 +669,7 @@ (tc-l #t (-val #t)) (tc-l "foo" -String) (tc-l foo (-val 'foo)) - (tc-l #:foo (-val '#:foo)) + (tc-l #:foo -Keyword) (tc-l #f (-val #f)) (tc-l #"foo" -Bytes) [tc-l () (-val null)] diff --git a/collects/typed-scheme/infer/infer-dummy.ss b/collects/typed-scheme/infer/infer-dummy.ss deleted file mode 100644 index d83922a61e..0000000000 --- a/collects/typed-scheme/infer/infer-dummy.ss +++ /dev/null @@ -1,8 +0,0 @@ -#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/infer/signatures.ss b/collects/typed-scheme/infer/signatures.ss deleted file mode 100644 index 6db02b38dc..0000000000 --- a/collects/typed-scheme/infer/signatures.ss +++ /dev/null @@ -1,29 +0,0 @@ -#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 deleted file mode 100644 index 470a7bed8a..0000000000 --- a/collects/typed-scheme/no-check.ss +++ /dev/null @@ -1,5 +0,0 @@ -#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 deleted file mode 100644 index c35cbecc78..0000000000 --- a/collects/typed-scheme/no-check/lang/reader.ss +++ /dev/null @@ -1,13 +0,0 @@ -#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 6600a1f7f2..59708588b1 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -3,7 +3,6 @@ ;; 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 @@ -16,12 +15,13 @@ ;; these are all for constructing the types given to variables (require (for-syntax scheme/base - (env init-envs) - (except-in (rep effect-rep type-rep) make-arr) + "init-envs.ss" + "effect-rep.ss" + (except-in "type-rep.ss" make-arr) "type-effect-convenience.ss" (only-in "type-effect-convenience.ss" [make-arr* make-arr]) "union.ss" - (typecheck tc-structs))) + "tc-structs.ss")) (define-for-syntax (initialize-others) (d-s date @@ -57,9 +57,6 @@ [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 @@ -148,13 +145,9 @@ [string-append (->* null -String -String)] [open-input-string (-> -String -Input-Port)] [open-output-file - (->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)] + (cl-> + [(-Pathlike) -Port] + [(-Pathlike Sym) -Port])] [read (cl-> [(-Port) -Sexp] [() -Sexp])] @@ -212,7 +205,9 @@ [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)) @@ -251,6 +246,7 @@ (- (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)))] @@ -471,7 +467,7 @@ [(-Bytes N) -Bytes] [(-Bytes N N) -Bytes])] [bytes-length (-> -Bytes N)] - [open-input-file (->key -Pathlike #:mode (Un (-val 'binary) (-val 'text)) #f -Input-Port)] + [open-input-file (-> -Pathlike -Input-Port)] [close-input-port (-> -Input-Port -Void)] [close-output-port (-> -Output-Port -Void)] [read-line (cl-> @@ -557,11 +553,8 @@ [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))] - - [eof (-val eof)] - [read-accept-reader (-Param 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))] ) (begin-for-syntax diff --git a/collects/typed-scheme/private/base-types.ss b/collects/typed-scheme/private/base-types.ss index 6058fd4b9c..cc4bb42a3d 100644 --- a/collects/typed-scheme/private/base-types.ss +++ b/collects/typed-scheme/private/base-types.ss @@ -1,10 +1,9 @@ #lang scheme/base -(require (except-in "../utils/utils.ss" extend)) (require (for-syntax scheme/base - (env init-envs) - (except-in (rep type-rep) make-arr) + "init-envs.ss" + (except-in "type-rep.ss" make-arr) "type-effect-convenience.ss" (only-in "type-effect-convenience.ss" [make-arr* make-arr]) "union.ss")) diff --git a/collects/typed-scheme/typecheck/check-subforms-unit.ss b/collects/typed-scheme/private/check-subforms-unit.ss similarity index 89% rename from collects/typed-scheme/typecheck/check-subforms-unit.ss rename to collects/typed-scheme/private/check-subforms-unit.ss index e37c6f3719..1658e455f1 100644 --- a/collects/typed-scheme/typecheck/check-subforms-unit.ss +++ b/collects/typed-scheme/private/check-subforms-unit.ss @@ -1,12 +1,15 @@ #lang scheme/unit -(require (except-in "../utils/utils.ss" extend)) (require syntax/kerncase scheme/match "signatures.ss" - (private type-utils type-effect-convenience union subtype) - (utils tc-utils) - (rep type-rep)) + "type-utils.ss" + "type-rep.ss" ;; doesn't need tests + "type-effect-convenience.ss" ;; maybe needs tests + "union.ss" + "subtype.ss" ;; has tests + "tc-utils.ss" ;; doesn't need tests + ) (import tc-if^ tc-lambda^ tc-app^ tc-let^ tc-expr^) (export check-subforms^) @@ -18,7 +21,7 @@ (define body-ty #f) (define (get-result-ty t) (match t - [(Function: (list (arr: _ rngs #f _ '() _ _) ...)) (apply Un rngs)] + [(Function: (list (arr: _ rngs #f _ _ _) ...)) (apply Un rngs)] [_ (tc-error "Internal error in get-result-ty: not a function type: ~n~a" t)])) (let loop ([form form]) (parameterize ([current-orig-stx form]) diff --git a/collects/typed-scheme/infer/constraint-structs.ss b/collects/typed-scheme/private/constraint-structs.ss similarity index 94% rename from collects/typed-scheme/infer/constraint-structs.ss rename to collects/typed-scheme/private/constraint-structs.ss index d5c970348b..def84ae0a6 100644 --- a/collects/typed-scheme/infer/constraint-structs.ss +++ b/collects/typed-scheme/private/constraint-structs.ss @@ -1,7 +1,6 @@ #lang scheme/base -(require (except-in "../utils/utils.ss" extend)) -(require (rep type-rep) +(require "type-rep.ss" scheme/contract) ;; S, T types diff --git a/collects/typed-scheme/infer/constraints.ss b/collects/typed-scheme/private/constraints.ss similarity index 94% rename from collects/typed-scheme/infer/constraints.ss rename to collects/typed-scheme/private/constraints.ss index 3dff2c088a..2697109ebe 100644 --- a/collects/typed-scheme/infer/constraints.ss +++ b/collects/typed-scheme/private/constraints.ss @@ -1,9 +1,8 @@ #lang scheme/unit -(require (except-in "../utils/utils.ss" extend)) -(require (private type-effect-convenience type-utils union subtype) - (rep type-rep) - (utils tc-utils) +(require "type-effect-convenience.ss" "type-rep.ss" + "type-utils.ss" "union.ss" "tc-utils.ss" + "subtype.ss" "utils.ss" "signatures.ss" "constraint-structs.ss" scheme/match) diff --git a/collects/typed-scheme/typecheck/def-binding.ss b/collects/typed-scheme/private/def-binding.ss similarity index 100% rename from collects/typed-scheme/typecheck/def-binding.ss rename to collects/typed-scheme/private/def-binding.ss diff --git a/collects/typed-scheme/typecheck/defstruct-unit.ss b/collects/typed-scheme/private/defstruct-unit.ss similarity index 100% rename from collects/typed-scheme/typecheck/defstruct-unit.ss rename to collects/typed-scheme/private/defstruct-unit.ss diff --git a/collects/typed-scheme/infer/dmap.ss b/collects/typed-scheme/private/dmap.ss similarity index 92% rename from collects/typed-scheme/infer/dmap.ss rename to collects/typed-scheme/private/dmap.ss index 9592668061..ef2112bae1 100644 --- a/collects/typed-scheme/infer/dmap.ss +++ b/collects/typed-scheme/private/dmap.ss @@ -1,8 +1,6 @@ #lang scheme/unit -(require (except-in "../utils/utils.ss" extend)) -(require "signatures.ss" "constraint-structs.ss" - (utils tc-utils) +(require "signatures.ss" "utils.ss" "tc-utils.ss" "constraint-structs.ss" scheme/match) (import constraints^) diff --git a/collects/typed-scheme/rep/effect-rep.ss b/collects/typed-scheme/private/effect-rep.ss similarity index 100% rename from collects/typed-scheme/rep/effect-rep.ss rename to collects/typed-scheme/private/effect-rep.ss diff --git a/collects/typed-scheme/private/extra-procs.ss b/collects/typed-scheme/private/extra-procs.ss index b5cd5378db..83aa9c4036 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* foo) +(provide assert call-with-values* values*) (define (assert v) (unless v @@ -15,7 +15,4 @@ (car as) (map car bss)))) (define call-with-values* call-with-values) -(define values* values) - -(define (foo x #:bar [bar #f]) - bar) \ No newline at end of file +(define values* values) \ No newline at end of file diff --git a/collects/typed-scheme/rep/free-variance.ss b/collects/typed-scheme/private/free-variance.ss similarity index 91% rename from collects/typed-scheme/rep/free-variance.ss rename to collects/typed-scheme/private/free-variance.ss index 7e4014e3ca..db9cb4f87e 100644 --- a/collects/typed-scheme/rep/free-variance.ss +++ b/collects/typed-scheme/private/free-variance.ss @@ -1,8 +1,7 @@ #lang scheme/base -(require "../utils/utils.ss") (require (for-syntax scheme/base) - (utils tc-utils) + "tc-utils.ss" mzlib/etc) ;; this file contains support for calculating the free variables/indexes of types @@ -28,8 +27,8 @@ (define var-table (make-weak-hasheq)) ;; maps Type to List[Cons[Symbol,Variance]] -(define (free-idxs* t) (hash-ref index-table t (lambda _ (int-err "type ~a not in index-table" (syntax-e t))))) -(define (free-vars* t) (hash-ref var-table t (lambda _ (int-err "type ~a not in var-table" (syntax-e t))))) +(define (free-idxs* t) (hash-ref index-table t (lambda _ (error "type not in index-table" (syntax-e t))))) +(define (free-vars* t) (hash-ref var-table t (lambda _ (error "type not in var-table" (syntax-e t))))) (define empty-hash-table (make-immutable-hasheq null)) diff --git a/collects/typed-scheme/private/infer-dummy.ss b/collects/typed-scheme/private/infer-dummy.ss new file mode 100644 index 0000000000..8645a31435 --- /dev/null +++ b/collects/typed-scheme/private/infer-dummy.ss @@ -0,0 +1,7 @@ +#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/infer/infer-unit.ss b/collects/typed-scheme/private/infer-unit.ss similarity index 92% rename from collects/typed-scheme/infer/infer-unit.ss rename to collects/typed-scheme/private/infer-unit.ss index c640d363ba..27ec65707c 100644 --- a/collects/typed-scheme/infer/infer-unit.ss +++ b/collects/typed-scheme/private/infer-unit.ss @@ -1,14 +1,12 @@ #lang scheme/unit -(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) +(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" "constraint-structs.ss" - "signatures.ss" - (only-in (env type-environments) lookup current-tvars) + (only-in "type-environments.ss" lookup current-tvars) scheme/match mzlib/etc mzlib/trace @@ -113,15 +111,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)))] @@ -137,8 +135,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)) @@ -148,10 +146,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 null 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 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)) @@ -161,10 +159,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 null 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 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? @@ -177,8 +175,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)] @@ -188,8 +186,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)) @@ -207,11 +205,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) null s-thn-eff s-els-eff))]) + (make-arr (append ss new-tys) s #f (cons s-dty dbound) 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/infer/infer.ss b/collects/typed-scheme/private/infer.ss similarity index 67% rename from collects/typed-scheme/infer/infer.ss rename to collects/typed-scheme/private/infer.ss index 208943a32f..d860e5f551 100644 --- a/collects/typed-scheme/infer/infer.ss +++ b/collects/typed-scheme/private/infer.ss @@ -1,10 +1,9 @@ #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) - (utils unit-utils)) + "unit-utils.ss") (provide-signature-elements restrict^ infer^) diff --git a/collects/typed-scheme/env/init-envs.ss b/collects/typed-scheme/private/init-envs.ss similarity index 90% rename from collects/typed-scheme/env/init-envs.ss rename to collects/typed-scheme/private/init-envs.ss index 4a03b9108d..d0dac77c0c 100644 --- a/collects/typed-scheme/env/init-envs.ss +++ b/collects/typed-scheme/private/init-envs.ss @@ -1,16 +1,11 @@ #lang scheme/base (provide (all-defined-out)) -(require "../utils/utils.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) +(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")) (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/typecheck/internal-forms.ss b/collects/typed-scheme/private/internal-forms.ss similarity index 100% rename from collects/typed-scheme/typecheck/internal-forms.ss rename to collects/typed-scheme/private/internal-forms.ss diff --git a/collects/typed-scheme/rep/interning.ss b/collects/typed-scheme/private/interning.ss similarity index 100% rename from collects/typed-scheme/rep/interning.ss rename to collects/typed-scheme/private/interning.ss diff --git a/collects/typed-scheme/env/lexical-env.ss b/collects/typed-scheme/private/lexical-env.ss similarity index 90% rename from collects/typed-scheme/env/lexical-env.ss rename to collects/typed-scheme/private/lexical-env.ss index 63a1295b76..e5946a3126 100644 --- a/collects/typed-scheme/env/lexical-env.ss +++ b/collects/typed-scheme/private/lexical-env.ss @@ -1,12 +1,6 @@ #lang scheme/base -(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)) +(require "type-environments.ss" "tc-utils.ss" "type-env.ss" "mutated-vars.ss" "type-utils.ss" "type-effect-convenience.ss") (provide (all-defined-out)) diff --git a/collects/typed-scheme/private/mutated-vars.ss b/collects/typed-scheme/private/mutated-vars.ss index a362bd5361..6e7a2c2da9 100644 --- a/collects/typed-scheme/private/mutated-vars.ss +++ b/collects/typed-scheme/private/mutated-vars.ss @@ -14,11 +14,12 @@ ;; syntax -> void (define (fmv/list lstx) (for-each find-mutated-vars (syntax->list lstx))) - ;(when (and (pair? (syntax->datum form))) (printf "called with ~a~n" (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)] @@ -27,13 +28,15 @@ [(begin0 . rest) (fmv/list #'rest)] [(#%plain-lambda _ . rest) (fmv/list #'rest)] [(case-lambda (_ . rest) ...) (for-each fmv/list (syntax->list #'(rest ...)))] - [(if . es) (fmv/list #'es)] - [(with-continuation-mark . es) (fmv/list #'es)] + [(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))] [(let-values ([_ e] ...) . b) (begin (fmv/list #'(e ...)) (fmv/list #'b))] [(letrec-values ([_ e] ...) . b) (begin (fmv/list #'(e ...)) - (fmv/list #'b))] - [(#%expression e) (find-mutated-vars #'e)] + (fmv/list #'b))] ;; 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 07adfd9e17..2b92c493d6 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -2,15 +2,16 @@ (provide parse-type parse-type/id) -(require (except-in "../utils/utils.ss" extend)) -(require (except-in (rep type-rep) make-arr) +(require (except-in "type-rep.ss" make-arr) "type-effect-convenience.ss" (only-in "type-effect-convenience.ss" [make-arr* make-arr]) - (utils tc-utils) + "tc-utils.ss" "union.ss" syntax/stx - (env type-environments type-name-env type-alias-env) - "type-utils.ss" + (except-in "type-environments.ss") + "type-name-env.ss" + "type-alias-env.ss" + "type-utils.ss" scheme/match) (define enable-mu-parsing (make-parameter #t)) @@ -212,7 +213,7 @@ ;(printf "found a type name ~a~n" #'id) (make-Name #'id)] [else - (tc-error/delayed "unbound type name ~a" (syntax-e #'id)) + (tc-error/delayed "unbound type ~a" (syntax-e #'id)) Univ])] [(All . rest) (eq? (syntax-e #'All) 'All) (tc-error "All: bad syntax")] diff --git a/collects/typed-scheme/utils/planet-requires.ss b/collects/typed-scheme/private/planet-requires.ss similarity index 100% rename from collects/typed-scheme/utils/planet-requires.ss rename to collects/typed-scheme/private/planet-requires.ss diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index 9068659cfd..ef3e7cc5a7 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 - (rep type-rep) + "type-rep.ss" mzlib/match "parse-type.ss" syntax/struct syntax/stx - (utils utils tc-utils) - (env type-name-env) + "utils.ss" + "tc-utils.ss" + "type-name-env.ss" "type-contract.ss")) (require "require-contract.ss" - (typecheck internal-forms) + "internal-forms.ss" (except-in mzlib/contract ->) (only-in mzlib/contract [-> c->]) mzlib/struct diff --git a/collects/typed-scheme/infer/promote-demote.ss b/collects/typed-scheme/private/promote-demote.ss similarity index 80% rename from collects/typed-scheme/infer/promote-demote.ss rename to collects/typed-scheme/private/promote-demote.ss index 8705122937..bbb1d7b229 100644 --- a/collects/typed-scheme/infer/promote-demote.ss +++ b/collects/typed-scheme/private/promote-demote.ss @@ -1,9 +1,8 @@ #lang scheme/unit -(require "../utils/utils.ss") -(require (rep type-rep) - (private type-effect-convenience union type-utils) - "signatures.ss" +(require "type-effect-convenience.ss" "type-rep.ss" + "type-utils.ss" "union.ss" + "signatures.ss" scheme/list) (import) @@ -27,7 +26,7 @@ [#:Param in out (make-Param (var-demote in V) (vp out))] - [#:arr dom rng rest drest kws thn els + [#:arr dom rng rest drest thn els (cond [(apply V-in? V (append thn els)) (make-arr null (Un) Univ #f null null)] @@ -36,8 +35,6 @@ (vp rng) (var-demote (car drest) V) #f - (for/list ([(kw kwt) (in-pairs kws)]) - (cons kw (var-demote kwt V))) thn els)] [else @@ -47,8 +44,6 @@ (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)])])) @@ -66,7 +61,7 @@ [#:Param in out (make-Param (var-promote in V) (vd out))] - [#:arr dom rng rest drest kws thn els + [#:arr dom rng rest drest thn els (cond [(apply V-in? V (append thn els)) (make-arr null (Un) Univ #f null null)] @@ -75,8 +70,6 @@ (vd rng) (var-promote (car drest) V) #f - (for/list ([(kw kwt) (in-pairs kws)]) - (cons kw (var-promote kwt V))) thn els)] [else @@ -86,7 +79,5 @@ (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/typecheck/provide-handling.ss b/collects/typed-scheme/private/provide-handling.ss similarity index 96% rename from collects/typed-scheme/typecheck/provide-handling.ss rename to collects/typed-scheme/private/provide-handling.ss index 4ca36a3460..1d4f67bfd1 100644 --- a/collects/typed-scheme/typecheck/provide-handling.ss +++ b/collects/typed-scheme/private/provide-handling.ss @@ -1,12 +1,11 @@ #lang scheme/base -(require (except-in "../utils/utils.ss" extend)) (require (only-in srfi/1/list s:member) syntax/kerncase mzlib/trace - (private type-contract) - (rep type-rep) - (utils tc-utils) + "type-contract.ss" + "type-rep.ss" + "tc-utils.ss" "def-binding.ss") (require (for-template scheme/base diff --git a/collects/typed-scheme/private/remove-intersect.ss b/collects/typed-scheme/private/remove-intersect.ss index d244fb7302..f9b273e80a 100644 --- a/collects/typed-scheme/private/remove-intersect.ss +++ b/collects/typed-scheme/private/remove-intersect.ss @@ -1,8 +1,7 @@ #lang scheme/base -(require (except-in "../utils/utils.ss" extend)) -(require (rep type-rep) - (private union subtype resolve-type type-effect-convenience type-utils) +(require "type-rep.ss" "union.ss" "subtype.ss" + "type-utils.ss" "resolve-type.ss" "type-effect-convenience.ss" mzlib/plt-match mzlib/trace) (provide (rename-out [*remove remove]) overlap) diff --git a/collects/typed-scheme/rep/rep-utils.ss b/collects/typed-scheme/private/rep-utils.ss similarity index 96% rename from collects/typed-scheme/rep/rep-utils.ss rename to collects/typed-scheme/private/rep-utils.ss index 2f49dba9f6..e3cf76e2d1 100644 --- a/collects/typed-scheme/rep/rep-utils.ss +++ b/collects/typed-scheme/private/rep-utils.ss @@ -1,18 +1,18 @@ #lang scheme/base -(require "../utils/utils.ss") (require mzlib/struct mzlib/plt-match syntax/boundmap - (utils planet-requires) + "planet-requires.ss" "free-variance.ss" + "utils.ss" "interning.ss" mzlib/etc (for-syntax scheme/base syntax/struct syntax/stx - (utils utils))) + "utils.ss")) (provide == dt de print-type* print-effect* Type Type? Effect Effect? defintern hash-id Type-seq Effect-seq) @@ -150,9 +150,7 @@ (lambda (s) (... (syntax-case s () - [(__ . fs) - (with-syntax ([flds** (syntax/loc s (_ . fs))]) - (quasisyntax/loc s (struct nm flds**)))])))) + [(__ . fs) (quasisyntax/loc s (struct nm #, (syntax/loc #'fs (_ . fs))))])))) (begin-for-syntax (hash-set! ht-stx 'kw-stx (list #'ex #'flds bfs-fold-rhs #'#,stx))) intern diff --git a/collects/typed-scheme/private/resolve-type.ss b/collects/typed-scheme/private/resolve-type.ss index 6526a42819..d68de69267 100644 --- a/collects/typed-scheme/private/resolve-type.ss +++ b/collects/typed-scheme/private/resolve-type.ss @@ -1,7 +1,6 @@ #lang scheme/base -(require "../utils/utils.ss") -(require (rep type-rep) (env type-name-env) (utils tc-utils) +(require "type-rep.ss" "type-name-env.ss" "tc-utils.ss" "type-utils.ss" mzlib/plt-match mzlib/trace) diff --git a/collects/typed-scheme/infer/restrict.ss b/collects/typed-scheme/private/restrict.ss similarity index 90% rename from collects/typed-scheme/infer/restrict.ss rename to collects/typed-scheme/private/restrict.ss index e13656056c..2c86a687b7 100644 --- a/collects/typed-scheme/infer/restrict.ss +++ b/collects/typed-scheme/private/restrict.ss @@ -1,8 +1,8 @@ #lang scheme/unit -(require "../utils/utils.ss") -(require (rep type-rep) - (private type-utils union remove-intersect subtype) +(require "type-rep.ss" + "type-utils.ss" "union.ss" + "subtype.ss" "remove-intersect.ss" "signatures.ss" scheme/match) diff --git a/collects/typed-scheme/typecheck/signatures.ss b/collects/typed-scheme/private/signatures.ss similarity index 56% rename from collects/typed-scheme/typecheck/signatures.ss rename to collects/typed-scheme/private/signatures.ss index 572becfda2..9f8b0dba0e 100644 --- a/collects/typed-scheme/typecheck/signatures.ss +++ b/collects/typed-scheme/private/signatures.ss @@ -2,11 +2,41 @@ (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)) + + + +;; cycle 2 + (define-signature typechecker^ (type-check tc-toplevel-form)) (define-signature tc-expr^ - (tc-expr tc-expr/check tc-expr/check/t check-below tc-literal tc-exprs tc-exprs/check tc-expr/t)) + (tc-expr tc-expr/check tc-expr/check/t check-below tc-literal tc-exprs tc-exprs/check tc-expr/t #;check-expr)) (define-signature check-subforms^ (check-subforms/ignore check-subforms/with-handlers check-subforms/with-handlers/check)) diff --git a/collects/typed-scheme/private/subtype.ss b/collects/typed-scheme/private/subtype.ss index 1db8c33be8..398fe7b226 100644 --- a/collects/typed-scheme/private/subtype.ss +++ b/collects/typed-scheme/private/subtype.ss @@ -1,13 +1,12 @@ #lang scheme/base -(require "../utils/utils.ss") -(require (except-in (rep type-rep effect-rep) sub-eff) - (utils tc-utils) - "type-utils.ss" +(require (except-in "type-rep.ss" sub-eff) "type-utils.ss" + "tc-utils.ss" + "effect-rep.ss" "type-comparison.ss" "resolve-type.ss" - (env type-name-env) - (only-in (infer infer-dummy) unify) + "type-name-env.ss" + (only-in "infer-dummy.ss" unify) mzlib/plt-match mzlib/trace) @@ -101,13 +100,10 @@ (match (list s t) ;; top for functions is above everything [(list _ (top-arr:)) A0] - [(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)]) + [(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)]) (subtype* A1 s2 t2))] - [(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*)) + [(list (arr: s1 s2 s3 #f thn-eff els-eff) (arr: t1 t2 t3 #f thn-eff* els-eff*)) (unless (or (and (null? thn-eff*) (null? els-eff*)) (and (effects-equal? thn-eff thn-eff*) @@ -119,11 +115,10 @@ (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* ([A2 (subtypes*/varargs A0 t1 s1 s3)] - [A3 (subtypes* A2 t-kw-ty s-kw-ty)]) + (let ([A (subtypes*/varargs A0 t1 s1 s3)]) (if (not t3) - (subtype* A3 s2 t2) - (let ([A1 (subtype* A3 t3 s3)]) + (subtype* A s2 t2) + (let ([A1 (subtype* A t3 s3)]) (subtype* A1 s2 t2))))] [else (fail! s t)]))) diff --git a/collects/typed-scheme/utils/syntax-traversal.ss b/collects/typed-scheme/private/syntax-traversal.ss similarity index 100% rename from collects/typed-scheme/utils/syntax-traversal.ss rename to collects/typed-scheme/private/syntax-traversal.ss diff --git a/collects/typed-scheme/utils/tables.ss b/collects/typed-scheme/private/tables.ss similarity index 100% rename from collects/typed-scheme/utils/tables.ss rename to collects/typed-scheme/private/tables.ss diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/private/tc-app-unit.ss similarity index 90% rename from collects/typed-scheme/typecheck/tc-app-unit.ss rename to collects/typed-scheme/private/tc-app-unit.ss index 3c04db1429..b1758d54ba 100644 --- a/collects/typed-scheme/typecheck/tc-app-unit.ss +++ b/collects/typed-scheme/private/tc-app-unit.ss @@ -1,13 +1,19 @@ #lang scheme/unit -(require (only-in "../utils/utils.ss" debug in-syntax printf/log in-pairs rep utils private env [infer r:infer])) (require "signatures.ss" - (rep type-rep effect-rep) - (utils tc-utils) - (private subtype type-utils union type-effect-convenience type-effect-printer resolve-type - type-annotation) - (r:infer infer) - (env type-environments) + "type-rep.ss" + "effect-rep.ss" + "tc-utils.ss" + "subtype.ss" + "infer.ss" + (only-in "utils.ss" debug in-syntax printf/log in-pairs) + "union.ss" + "type-utils.ss" + "type-effect-convenience.ss" + "type-effect-printer.ss" + "type-annotation.ss" + "resolve-type.ss" + "type-environments.ss" (only-in srfi/1 alist-delete) (only-in scheme/private/class-internal make-object do-make-object) mzlib/trace mzlib/pretty syntax/kerncase scheme/match @@ -15,7 +21,7 @@ (for-template "internal-forms.ss" scheme/base (only-in scheme/private/class-internal make-object do-make-object))) -(require (r:infer constraint-structs)) +(require "constraint-structs.ss") (import tc-expr^ tc-lambda^ tc-dots^) (export tc-app^) @@ -153,7 +159,7 @@ (define-values (fixed-args tail) (split (syntax->list 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")) @@ -198,7 +204,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))]) @@ -208,7 +214,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" @@ -253,14 +259,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" @@ -372,8 +378,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")]) @@ -423,8 +429,7 @@ "Wrong number of arguments to parameter - expected 0 or 1, got ~a" (length argtypes))])] ;; single clause functions - ;; FIXME - error on non-optional keywords - [(tc-result: (and t (Function: (list (arr: dom rng rest #f _ latent-thn-effs latent-els-effs)))) + [(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 @@ -432,7 +437,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*) @@ -448,19 +453,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))) @@ -469,7 +474,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)) @@ -561,47 +566,6 @@ [(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 @@ -621,7 +585,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" @@ -657,23 +621,11 @@ [(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)] - ;; 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)])] + [(#%plain-app apply f . args) (tc/apply #'f #'args)] ;; 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/typecheck/tc-dots-unit.ss b/collects/typed-scheme/private/tc-dots-unit.ss similarity index 89% rename from collects/typed-scheme/typecheck/tc-dots-unit.ss rename to collects/typed-scheme/private/tc-dots-unit.ss index aa2c7c17b1..803ef905db 100644 --- a/collects/typed-scheme/typecheck/tc-dots-unit.ss +++ b/collects/typed-scheme/private/tc-dots-unit.ss @@ -1,11 +1,10 @@ #lang scheme/unit -(require (except-in "../utils/utils.ss" extend)) (require "signatures.ss" - (utils tc-utils) - (env type-environments) - (private type-utils) - (rep type-rep) + "tc-utils.ss" + "type-environments.ss" + "type-utils.ss" + "type-rep.ss" syntax/kerncase scheme/match) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/private/tc-expr-unit.ss similarity index 95% rename from collects/typed-scheme/typecheck/tc-expr-unit.ss rename to collects/typed-scheme/private/tc-expr-unit.ss index c61bbd3d9f..feb7129a36 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/private/tc-expr-unit.ss @@ -1,15 +1,21 @@ #lang scheme/unit -(require (rename-in "../utils/utils.ss" [private r:private])) (require syntax/kerncase scheme/match "signatures.ss" - (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) + "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) scheme/private/class-internal (only-in srfi/1 split-at)) @@ -35,7 +41,7 @@ [(null? v) (-val null)] [(symbol? v) (-val v)] [(string? v) -String] - [(keyword? v) (-val v)] + [(keyword? v) -Keyword] [(bytes? v) -Bytes] [(list? v) (-Tuple (map tc-literal v))] [(vector? v) (make-Vector (types-of-literals (vector->list v)))] @@ -95,8 +101,7 @@ ;; 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] - [t (int-err "tc-expr returned ~a, not a tc-result, for ~a" t (syntax->datum e))])) + [(tc-result: t) t])) (define (tc-expr/check/t e t) (match (tc-expr/check e t) diff --git a/collects/typed-scheme/typecheck/tc-if-unit.ss b/collects/typed-scheme/private/tc-if-unit.ss similarity index 95% rename from collects/typed-scheme/typecheck/tc-if-unit.ss rename to collects/typed-scheme/private/tc-if-unit.ss index e1d75c236c..f59b19fe60 100644 --- a/collects/typed-scheme/typecheck/tc-if-unit.ss +++ b/collects/typed-scheme/private/tc-if-unit.ss @@ -1,15 +1,20 @@ #lang scheme/unit -(require (rename-in "../utils/utils.ss" [infer r:infer])) -(require (utils planet-requires) +(require "planet-requires.ss" "signatures.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) + "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" [remove *remove]) - (r:infer infer) - (utils tc-utils) + "infer.ss" + "union.ss" + "type-utils.ss" + "tc-utils.ss" + "type-comparison.ss" syntax/kerncase mzlib/trace mzlib/plt-match) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/private/tc-lambda-unit.ss similarity index 96% rename from collects/typed-scheme/typecheck/tc-lambda-unit.ss rename to collects/typed-scheme/private/tc-lambda-unit.ss index 962c480e05..d91531536e 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/private/tc-lambda-unit.ss @@ -1,15 +1,20 @@ #lang scheme/unit -(require (rename-in "../utils/utils.ss" [infer r:infer] [extend r:extend])) (require "signatures.ss" mzlib/trace scheme/list - (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) + (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" mzlib/plt-match - (only-in (private type-effect-convenience) [make-arr* make-arr])) + (only-in "type-effect-convenience.ss" [make-arr* make-arr])) (require (for-template scheme/base "internal-forms.ss")) (import tc-expr^) @@ -175,7 +180,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/typecheck/tc-let-unit.ss b/collects/typed-scheme/private/tc-let-unit.ss similarity index 96% rename from collects/typed-scheme/typecheck/tc-let-unit.ss rename to collects/typed-scheme/private/tc-let-unit.ss index 9bf2bf3fa7..eb29285264 100644 --- a/collects/typed-scheme/typecheck/tc-let-unit.ss +++ b/collects/typed-scheme/private/tc-let-unit.ss @@ -1,9 +1,14 @@ #lang scheme/unit -(require (rename-in "../utils/utils.ss" [infer r:infer])) (require "signatures.ss" - (private type-effect-convenience type-annotation parse-type type-utils) - (env lexical-env type-alias-env type-env) + "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" syntax/free-vars mzlib/trace scheme/match diff --git a/collects/typed-scheme/typecheck/tc-structs.ss b/collects/typed-scheme/private/tc-structs.ss similarity index 95% rename from collects/typed-scheme/typecheck/tc-structs.ss rename to collects/typed-scheme/private/tc-structs.ss index 86233c0df2..23c8a43038 100644 --- a/collects/typed-scheme/typecheck/tc-structs.ss +++ b/collects/typed-scheme/private/tc-structs.ss @@ -1,12 +1,15 @@ #lang scheme/base -(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) +(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" "def-binding.ss" syntax/kerncase syntax/struct diff --git a/collects/typed-scheme/typecheck/tc-toplevel.ss b/collects/typed-scheme/private/tc-toplevel.ss similarity index 94% rename from collects/typed-scheme/typecheck/tc-toplevel.ss rename to collects/typed-scheme/private/tc-toplevel.ss index 5f2d36f25b..23b3614c57 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.ss +++ b/collects/typed-scheme/private/tc-toplevel.ss @@ -1,17 +1,26 @@ #lang scheme/unit -(require (rename-in "../utils/utils.ss" [infer r:infer])) (require syntax/kerncase mzlib/etc scheme/match "signatures.ss" "tc-structs.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" + "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" "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/utils/tc-utils.ss b/collects/typed-scheme/private/tc-utils.ss similarity index 97% rename from collects/typed-scheme/utils/tc-utils.ss rename to collects/typed-scheme/private/tc-utils.ss index 132b220612..69709e3e46 100644 --- a/collects/typed-scheme/utils/tc-utils.ss +++ b/collects/typed-scheme/private/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 #f)) +(define delay-errors? (make-parameter #t)) (define (tc-error/delayed msg #:stx [stx* (current-orig-stx)] . rest) (let ([stx (locate-stx stx*)]) (unless (syntax? stx) - (int-err "erroneous syntax was not a syntax object: ~a ~a" stx (syntax->datum stx*))) + (error "syntax was not syntax" 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/env/type-alias-env.ss b/collects/typed-scheme/private/type-alias-env.ss similarity index 96% rename from collects/typed-scheme/env/type-alias-env.ss rename to collects/typed-scheme/private/type-alias-env.ss index dd9183d32c..0be4da74a5 100644 --- a/collects/typed-scheme/env/type-alias-env.ss +++ b/collects/typed-scheme/private/type-alias-env.ss @@ -1,8 +1,7 @@ #lang scheme/base -(require (except-in "../utils/utils.ss" extend)) (require syntax/boundmap - (utils tc-utils) + "tc-utils.ss" mzlib/trace scheme/match) diff --git a/collects/typed-scheme/private/type-annotation.ss b/collects/typed-scheme/private/type-annotation.ss index bbb8303412..1a72e73bdd 100644 --- a/collects/typed-scheme/private/type-annotation.ss +++ b/collects/typed-scheme/private/type-annotation.ss @@ -1,11 +1,7 @@ #lang scheme/base -(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" +(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" 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 dbc70e5f46..dab6743a78 100644 --- a/collects/typed-scheme/private/type-comparison.ss +++ b/collects/typed-scheme/private/type-comparison.ss @@ -1,4 +1,3 @@ #lang scheme/base -(require "../utils/utils.ss") -(require (rep type-rep) "type-utils.ss") +(require "type-rep.ss" "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 - (rep type-rep) - (typecheck internal-forms) - (utils tc-utils) - (env type-name-env) + "type-rep.ss" "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 13aa199c91..9ae26d5479 100644 --- a/collects/typed-scheme/private/type-effect-convenience.ss +++ b/collects/typed-scheme/private/type-effect-convenience.ss @@ -1,16 +1,14 @@ #lang scheme/base -(require "../utils/utils.ss") - -(require (rep type-rep effect-rep) - (utils tc-utils) +(require "type-rep.ss" + "effect-rep.ss" 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)) @@ -35,7 +33,7 @@ [(Latent-Remove-Effect: t) (make-Remove-Effect t v)] [(True-Effect:) eff] [(False-Effect:) eff] - [_ (int-err "can't add var ~a to effect ~a" v eff)])) + [_ (error 'internal-tc-error "can't add var to effect ~a" eff)])) (define-syntax (-> stx) (syntax-case* stx (:) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) @@ -80,26 +78,11 @@ [(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 #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 e-rec-id ty clauses ...) (begin (map add-clause (syntax->list #'(clauses ...))) @@ -314,7 +296,7 @@ ;; necessary to avoid infinite loops [#:Union elems (*Union (remove-dups (sort (map sb elems) typelist #'(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) + in-syntax) (define-sequence-syntax in-syntax (lambda () #'syntax->list) diff --git a/collects/typed-scheme/typed-scheme.ss b/collects/typed-scheme/typed-scheme.ss index 0bcfc701b0..19c9c9cb7d 100644 --- a/collects/typed-scheme/typed-scheme.ss +++ b/collects/typed-scheme/typed-scheme.ss @@ -1,18 +1,22 @@ #lang scheme/base -(require (rename-in "utils/utils.ss" [infer r:infer])) - -(require (private base-env base-types) +(require "private/base-env.ss" + "private/base-types.ss" (for-syntax scheme/base - (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) + "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" scheme/nest syntax/kerncase scheme/match)) @@ -27,7 +31,7 @@ (provide (rename-out [module-begin #%module-begin] [top-interaction #%top-interaction] [#%plain-lambda lambda] - [#%app #%app] + [#%plain-app #%app] [require require])) (define-for-syntax catch-errors? #f)