diff --git a/collects/typed-racket/typecheck/signatures.rkt b/collects/typed-racket/typecheck/signatures.rkt index 8b52516e..c3773191 100644 --- a/collects/typed-racket/typecheck/signatures.rkt +++ b/collects/typed-racket/typecheck/signatures.rkt @@ -31,34 +31,6 @@ ([cond-contracted tc/app (syntax? . -> . tc-results?)] [cond-contracted tc/app/check (syntax? tc-results? . -> . tc-results?)])) -(define-signature tc-app-hetero^ - ([cond-contracted tc/app-hetero (syntax? (or/c #f tc-results?). -> . (or/c #f tc-results?))])) - -(define-signature tc-app-list^ - ([cond-contracted tc/app-list (syntax? (or/c #f tc-results?). -> . (or/c #f tc-results?))])) - -(define-signature tc-app-apply^ - ([cond-contracted tc/app-apply (syntax? (or/c #f tc-results?). -> . (or/c #f tc-results?))])) - -(define-signature tc-app-values^ - ([cond-contracted tc/app-values (syntax? (or/c #f tc-results?). -> . (or/c #f tc-results?))])) - -(define-signature tc-app-keywords^ - ([cond-contracted tc/app-keywords (syntax? (or/c #f tc-results?). -> . (or/c #f tc-results?))])) - -(define-signature tc-app-objects^ - ([cond-contracted tc/app-objects (syntax? (or/c #f tc-results?). -> . (or/c #f tc-results?))])) - -(define-signature tc-app-eq^ - ([cond-contracted tc/app-eq (syntax? (or/c #f tc-results?). -> . (or/c #f tc-results?))])) - -(define-signature tc-app-lambda^ - ([cond-contracted tc/app-lambda (syntax? (or/c #f tc-results?). -> . (or/c #f tc-results?))])) - -(define-signature tc-app-special^ - ([cond-contracted tc/app-special (syntax? (or/c #f tc-results?). -> . (or/c #f tc-results?))])) - - (define-signature tc-apply^ ([cond-contracted tc/apply (syntax? syntax? . -> . tc-results?)])) diff --git a/collects/typed-racket/typecheck/tc-app-helper.rkt b/collects/typed-racket/typecheck/tc-app-helper.rkt index 2ba7436d..5ff5efcb 100644 --- a/collects/typed-racket/typecheck/tc-app-helper.rkt +++ b/collects/typed-racket/typecheck/tc-app-helper.rkt @@ -11,11 +11,6 @@ (provide (all-defined-out)) -(define-syntax-class special-op - (pattern i:identifier - #:when (or (syntax-property #'i 'type-inst) - (syntax-property #'i 'type-ascription)))) - ;; syntax? syntax? arr? (listof tc-results?) (or/c #f tc-results) [boolean?] -> tc-results? (define/cond-contract (tc/funapp1 f-stx args-stx ftype0 argtys expected #:check [check? #t]) ((syntax? (c:and/c syntax? syntax->list) arr? (c:listof tc-results?) (c:or/c #f tc-results?)) (#:check boolean?) . c:->* . tc-results?) diff --git a/collects/typed-racket/typecheck/tc-app.rkt b/collects/typed-racket/typecheck/tc-app.rkt index 09722293..abc99e31 100644 --- a/collects/typed-racket/typecheck/tc-app.rkt +++ b/collects/typed-racket/typecheck/tc-app.rkt @@ -1,32 +1,13 @@ #lang racket/unit -(require (rename-in "../utils/utils.rkt" [infer r:infer]) - "signatures.rkt" "tc-metafunctions.rkt" "check-below.rkt" - "tc-app-helper.rkt" "find-annotation.rkt" "tc-funapp.rkt" - "tc-subst.rkt" (prefix-in c: racket/contract) - syntax/parse racket/match racket/list - unstable/sequence unstable/list - ;; fixme - don't need to be bound in this phase - only to make tests work - racket/bool - racket/unsafe/ops - (only-in syntax/location module-name-fixup) - ;; end fixme - (for-syntax syntax/parse racket/base (utils tc-utils)) - (private type-annotation) - (types utils union subtype resolve abbrev - type-table substitute generalize) - (utils tc-utils) - (except-in (env type-env-structs tvar-env index-env) extend) - (rep type-rep filter-rep object-rep rep-utils) - (r:infer infer) - '#%paramz - (for-template - racket/unsafe/ops racket/fixnum racket/flonum - "internal-forms.rkt" racket/base racket/bool '#%paramz - - (only-in syntax/location module-name-fixup))) +(require "../utils/utils.rkt" + "tc-app/signatures.rkt" + syntax/parse racket/match + (typecheck signatures check-below tc-funapp) + (types utils abbrev) + (rep type-rep filter-rep object-rep rep-utils)) -(import tc-expr^ tc-lambda^ tc-let^ tc-apply^ tc-app-keywords^ +(import tc-expr^ tc-app-keywords^ tc-app-hetero^ tc-app-list^ tc-app-apply^ tc-app-values^ tc-app-objects^ tc-app-eq^ tc-app-lambda^ tc-app-special^) (export tc-app^) @@ -48,11 +29,17 @@ (tc/app-special form expected) (tc/app-regular form expected))) + +(define-syntax-class annotated-op + (pattern i:identifier + #:when (or (syntax-property #'i 'type-inst) + (syntax-property #'i 'type-ascription)))) + (define (tc/app-annotated form expected) (syntax-parse form #:literals (#%plain-app) - ;; bail out immediately if we have one of these - [(#%plain-app rator:special-op . rands) (tc/app-regular form expected)] + ;; Just do regular typechecking if we have one of these. + [(#%plain-app rator:annotated-op . rands) (tc/app-regular form expected)] [_ #f])) (define (tc/app-regular form expected) diff --git a/collects/typed-racket/typecheck/tc-app/signatures.rkt b/collects/typed-racket/typecheck/tc-app/signatures.rkt new file mode 100644 index 00000000..ebce2d57 --- /dev/null +++ b/collects/typed-racket/typecheck/tc-app/signatures.rkt @@ -0,0 +1,36 @@ +#lang racket/base +(require racket/unit + "../../utils/utils.rkt" "../../utils/unit-utils.rkt" + racket/contract + (types utils)) +(provide (except-out (all-defined-out) checker/c)) + +(define checker/c (syntax? (or/c #f tc-results?). -> . (or/c #f tc-results?))) + +(define-signature tc-app-hetero^ + ([cond-contracted tc/app-hetero checker/c])) + +(define-signature tc-app-list^ + ([cond-contracted tc/app-list checker/c])) + +(define-signature tc-app-apply^ + ([cond-contracted tc/app-apply checker/c])) + +(define-signature tc-app-values^ + ([cond-contracted tc/app-values checker/c])) + +(define-signature tc-app-keywords^ + ([cond-contracted tc/app-keywords checker/c])) + +(define-signature tc-app-objects^ + ([cond-contracted tc/app-objects checker/c])) + +(define-signature tc-app-eq^ + ([cond-contracted tc/app-eq checker/c])) + +(define-signature tc-app-lambda^ + ([cond-contracted tc/app-lambda checker/c])) + +(define-signature tc-app-special^ + ([cond-contracted tc/app-special checker/c])) + diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-apply.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-apply.rkt index 1c699109..fd8eb3ba 100644 --- a/collects/typed-racket/typecheck/tc-app/tc-app-apply.rkt +++ b/collects/typed-racket/typecheck/tc-app/tc-app-apply.rkt @@ -1,8 +1,9 @@ #lang racket/unit (require "../../utils/utils.rkt" + "signatures.rkt" syntax/parse racket/match - (typecheck signatures tc-app-helper tc-funapp check-below tc-subst) + (typecheck signatures tc-funapp check-below tc-subst) (types abbrev utils) (rep type-rep) @@ -20,7 +21,6 @@ (define (tc/app-apply form expected) (syntax-parse form #:literals (#%plain-app k:apply apply values) - [(#%plain-app op:special-op args ...) #f] ;; rewrite this so that it takes advantages of all the special cases [(#%plain-app k:apply . args) (tc/app-apply (syntax/loc form (#%plain-app apply . args)) expected)] diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-eq.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-eq.rkt index 090e99d0..1838e405 100644 --- a/collects/typed-racket/typecheck/tc-app/tc-app-eq.rkt +++ b/collects/typed-racket/typecheck/tc-app/tc-app-eq.rkt @@ -1,12 +1,17 @@ #lang racket/unit (require "../../utils/utils.rkt" + "signatures.rkt" syntax/parse racket/match - (typecheck signatures tc-app-helper tc-funapp check-below) + (typecheck signatures tc-funapp check-below) (types abbrev union utils) (rep type-rep) - (for-template racket/base)) + ;; fixme - don't need to be bound in this phase - only to make tests work + racket/bool + ;; end fixme + + (for-template racket/base racket/bool)) (import tc-expr^) (export tc-app-eq^) diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt index 732ecc1f..9639d551 100644 --- a/collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt +++ b/collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt @@ -1,8 +1,9 @@ #lang racket/unit (require (rename-in "../../utils/utils.rkt" [infer r:infer]) + "signatures.rkt" "../signatures.rkt" "../tc-metafunctions.rkt" "../check-below.rkt" - "../tc-app-helper.rkt" "../find-annotation.rkt" "../tc-funapp.rkt" + "../find-annotation.rkt" "../tc-funapp.rkt" "../tc-subst.rkt" (prefix-in c: racket/contract) syntax/parse racket/match racket/trace scheme/list unstable/sequence unstable/list @@ -99,7 +100,6 @@ unsafe-struct-ref unsafe-struct*-ref unsafe-struct-set! unsafe-struct*-set! vector-immutable vector) - [(#%plain-app op:special-op args ...) #f] ;; unsafe struct-ref [(#%plain-app (~or unsafe-struct-ref unsafe-struct*-ref) struct:expr index:expr) (match (single-value #'struct) diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-keywords.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-keywords.rkt index 114cc853..2b3cbdc3 100644 --- a/collects/typed-racket/typecheck/tc-app/tc-app-keywords.rkt +++ b/collects/typed-racket/typecheck/tc-app/tc-app-keywords.rkt @@ -2,6 +2,7 @@ #lang racket/unit (require (rename-in "../../utils/utils.rkt" [infer r:infer]) + "signatures.rkt" syntax/parse racket/match (typecheck signatures tc-app-helper tc-funapp tc-metafunctions) (types abbrev utils union substitute subtype) @@ -18,7 +19,6 @@ (define (tc/app-keywords form expected) (syntax-parse form #:literals (#%plain-app list) - [(#%plain-app op:special-op args ...) #f] [(#%plain-app (#%plain-app cpce s-kp fn kpe kws num) kw-list diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-lambda.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-lambda.rkt index 9100e412..2919458f 100644 --- a/collects/typed-racket/typecheck/tc-app/tc-app-lambda.rkt +++ b/collects/typed-racket/typecheck/tc-app/tc-app-lambda.rkt @@ -1,9 +1,10 @@ #lang racket/unit (require "../../utils/utils.rkt" + "signatures.rkt" syntax/parse racket/match racket/list unstable/sequence - (typecheck signatures tc-app-helper tc-funapp check-below find-annotation ) + (typecheck signatures tc-funapp check-below find-annotation ) (types abbrev utils generalize type-table) (private type-annotation) (rep type-rep) diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-list.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-list.rkt index 37b187d8..0ec351b4 100644 --- a/collects/typed-racket/typecheck/tc-app/tc-app-list.rkt +++ b/collects/typed-racket/typecheck/tc-app/tc-app-list.rkt @@ -2,9 +2,10 @@ (require "../../utils/utils.rkt" + "signatures.rkt" syntax/parse racket/match (only-in '#%kernel [reverse k:reverse]) - (typecheck signatures tc-app-helper tc-funapp check-below) + (typecheck signatures tc-funapp check-below) (types abbrev utils union substitute) (rep type-rep) (env tvar-env) @@ -27,7 +28,6 @@ #:literals (#%plain-app reverse k:reverse list list* cons map andmap ormap) - [(#%plain-app op:special-op args ...) #f] [(#%plain-app map f arg0 arg ...) (match* ((single-value #'arg0) (map single-value (syntax->list #'(arg ...)))) ;; if the argument is a ListDots diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-objects.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-objects.rkt index 17493425..cf106260 100644 --- a/collects/typed-racket/typecheck/tc-app/tc-app-objects.rkt +++ b/collects/typed-racket/typecheck/tc-app/tc-app-objects.rkt @@ -1,8 +1,9 @@ #lang racket/unit (require "../../utils/utils.rkt" + "signatures.rkt" syntax/parse racket/match unstable/sequence - (typecheck signatures tc-app-helper tc-funapp check-below) + (typecheck signatures tc-funapp check-below) (types abbrev union utils) (rep type-rep) (utils tc-utils) diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-special.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-special.rkt index 302d3b7b..d5328c91 100644 --- a/collects/typed-racket/typecheck/tc-app/tc-app-special.rkt +++ b/collects/typed-racket/typecheck/tc-app/tc-app-special.rkt @@ -1,15 +1,21 @@ #lang racket/unit (require "../../utils/utils.rkt" + "signatures.rkt" syntax/parse racket/match unstable/list - (typecheck signatures tc-app-helper tc-funapp check-below) + (typecheck signatures tc-funapp check-below) (types abbrev utils) (private type-annotation) (rep type-rep filter-rep) (utils tc-utils) - (for-template racket/base)) + ;; fixme - don't need to be bound in this phase - only to make tests work + racket/bool + '#%paramz + ;; end fixme + + (for-template racket/base racket/bool '#%paramz)) (import tc-expr^) diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-values.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-values.rkt index df09e3eb..3ddbbc96 100644 --- a/collects/typed-racket/typecheck/tc-app/tc-app-values.rkt +++ b/collects/typed-racket/typecheck/tc-app/tc-app-values.rkt @@ -1,8 +1,9 @@ #lang racket/unit (require "../../utils/utils.rkt" + "signatures.rkt" syntax/parse racket/match - (typecheck signatures tc-app-helper tc-funapp check-below) + (typecheck signatures tc-funapp check-below) (types abbrev utils) (rep type-rep) @@ -15,7 +16,6 @@ (define (tc/app-values form expected) (syntax-parse form #:literals (#%plain-app values call-with-values) - [(#%plain-app op:special-op args ...) #f] ;; call-with-values [(#%plain-app call-with-values prod con) (match (tc/funapp #'prod #'() (single-value #'prod) null #f) diff --git a/collects/typed-racket/typecheck/typechecker.rkt b/collects/typed-racket/typecheck/typechecker.rkt index a4bcf1e2..4843511e 100644 --- a/collects/typed-racket/typecheck/typechecker.rkt +++ b/collects/typed-racket/typecheck/typechecker.rkt @@ -6,23 +6,13 @@ provide-signature-elements define-values/invoke-unit/infer link) "signatures.rkt" - "tc-app/tc-app-apply.rkt" - "tc-app/tc-app-eq.rkt" - "tc-app/tc-app-hetero.rkt" - "tc-app/tc-app-keywords.rkt" - "tc-app/tc-app-lambda.rkt" - "tc-app/tc-app-list.rkt" - "tc-app/tc-app-objects.rkt" - "tc-app/tc-app-special.rkt" - "tc-app/tc-app-values.rkt" - "signatures.rkt" - "tc-if.rkt" "tc-lambda-unit.rkt" "tc-app.rkt" + "tc-app/tc-app-combined.rkt" + "tc-if.rkt" "tc-lambda-unit.rkt" "tc-let-unit.rkt" "tc-apply.rkt" "tc-expr-unit.rkt" "check-subforms-unit.rkt") (provide-signature-elements tc-expr^ check-subforms^) (define-values/invoke-unit/infer - (link tc-if@ tc-lambda@ tc-app@ tc-let@ tc-expr@ check-subforms@ tc-apply@ - tc-app-hetero@ tc-app-list@ tc-app-apply@ tc-app-values@ tc-app-keywords@ - tc-app-objects@ tc-app-eq@ tc-app-lambda@ tc-app-special@)) + (link tc-if@ tc-lambda@ tc-app-combined@ tc-let@ tc-expr@ + check-subforms@ tc-apply@))