From 543b1e3069c2def61d539bf0f269d4cbabd560f9 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Thu, 16 Aug 2012 22:17:37 -0700 Subject: [PATCH] Moved last special cases out of tc-app.rkt. original commit: 54d49d0ec163a149948d2c8337f6de66d1ec3be2 --- .../typed-racket/typecheck/signatures.rkt | 3 + collects/typed-racket/typecheck/tc-app.rkt | 86 +++++-------------- .../typecheck/tc-app/tc-app-special.rkt | 73 ++++++++++++++++ .../typed-racket/typecheck/typechecker.rkt | 3 +- 4 files changed, 99 insertions(+), 66 deletions(-) create mode 100644 collects/typed-racket/typecheck/tc-app/tc-app-special.rkt diff --git a/collects/typed-racket/typecheck/signatures.rkt b/collects/typed-racket/typecheck/signatures.rkt index 91be6c6b..8b52516e 100644 --- a/collects/typed-racket/typecheck/signatures.rkt +++ b/collects/typed-racket/typecheck/signatures.rkt @@ -55,6 +55,9 @@ (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.rkt b/collects/typed-racket/typecheck/tc-app.rkt index 64b3d684..09722293 100644 --- a/collects/typed-racket/typecheck/tc-app.rkt +++ b/collects/typed-racket/typecheck/tc-app.rkt @@ -28,78 +28,34 @@ (import tc-expr^ tc-lambda^ tc-let^ tc-apply^ 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-objects^ tc-app-eq^ tc-app-lambda^ tc-app-special^) (export tc-app^) ;; the main dispatching function ;; syntax tc-results? -> tc-results? (define (tc/app/internal form expected) - (or (tc/app-hetero form expected) - (tc/app-list form expected) - (tc/app-apply form expected) - (tc/app-values form expected) - (tc/app-keywords form expected) - (tc/app-objects form expected) - (tc/app-eq form expected) - (tc/app-lambda form expected) - (syntax-parse form - #:literals (#%plain-app #%plain-lambda letrec-values quote - not false? list - module-name-fixup cons - extend-parameterization) - ;; bail out immediately if we have one of these - [(#%plain-app rator:special-op . rands) (tc/app/regular form expected)] - [(#%plain-app extend-parameterization pmz args ...) - (let loop ([args (syntax->list #'(args ...))]) - (if (null? args) (ret Univ) - (let* ([p (car args)] - [pt (single-value p)] - [v (cadr args)] - [vt (single-value v)]) - (match pt - [(tc-result1: (Param: a b)) - (check-below vt a) - (loop (cddr args))] - [(tc-result1: t) - (tc-error/expr #:return (or expected (ret Univ)) "expected Parameter, but got ~a" t) - (loop (cddr args))]))))] - ;; use the additional but normally ignored first argument to make-sequence - ;; to provide a better instantiation - [(#%plain-app (~var op (id-from 'make-sequence 'racket/private/for)) - (~and quo (quote (i:id ...))) arg:expr) - #:when (andmap type-annotation (syntax->list #'(i ...))) - (match (single-value #'op) - [(tc-result1: (and t Poly?)) - (tc-expr/check #'quo (ret Univ)) - (tc/funapp #'op #'(quo arg) - (ret (instantiate-poly t (extend (list Univ Univ) - (map type-annotation (syntax->list #'(i ...))) - Univ))) - (list (ret Univ) (single-value #'arg)) - expected)])] - ;; special-case for not - flip the filters - [(#%plain-app (~or false? not) arg) - (match (single-value #'arg) - [(tc-result1: t (FilterSet: f+ f-) _) - (ret -Boolean (make-FilterSet f- f+))])] - ;; special case for (current-contract-region)'s default expansion - ;; just let it through without any typechecking, since module-name-fixup - ;; is a private function from syntax/location, so this must have been - ;; (quote-module-name) originally. - [(#%plain-app module-name-fixup src path) - (ret Univ)] - ;; special case for `delay' - [(#%plain-app - mp1 - (#%plain-lambda () - (#%plain-app mp2 (#%plain-app call-with-values (#%plain-lambda () e) list)))) - #:declare mp1 (id-from 'make-promise 'racket/promise) - #:declare mp2 (id-from 'make-promise 'racket/promise) - (ret (-Promise (tc-expr/t #'e)))] - [_ (tc/app/regular form expected)]))) + (or + (tc/app-annotated form expected) + (tc/app-hetero form expected) + (tc/app-list form expected) + (tc/app-apply form expected) + (tc/app-values form expected) + (tc/app-keywords form expected) + (tc/app-objects form expected) + (tc/app-eq form expected) + (tc/app-lambda form expected) + (tc/app-special form expected) + (tc/app-regular form expected))) -(define (tc/app/regular form expected) +(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)] + [_ #f])) + +(define (tc/app-regular form expected) (syntax-parse form #:literals (#%plain-app) [(#%plain-app f . args) (let* ([f-ty (single-value #'f)]) diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-special.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-special.rkt new file mode 100644 index 00000000..302d3b7b --- /dev/null +++ b/collects/typed-racket/typecheck/tc-app/tc-app-special.rkt @@ -0,0 +1,73 @@ +#lang racket/unit + +(require "../../utils/utils.rkt" + syntax/parse racket/match + unstable/list + (typecheck signatures tc-app-helper tc-funapp check-below) + (types abbrev utils) + (private type-annotation) + (rep type-rep filter-rep) + (utils tc-utils) + + (for-template racket/base)) + + +(import tc-expr^) +(export tc-app-special^) + +(define (tc/app-special form expected) + (syntax-parse form + #:literals (#%plain-app #%plain-lambda extend-parameterization quote + false? not call-with-values list) + ;; parameterize + [(#%plain-app extend-parameterization pmz args ...) + (let loop ([args (syntax->list #'(args ...))]) + (if (null? args) (ret Univ) + (let* ([p (car args)] + [pt (single-value p)] + [v (cadr args)] + [vt (single-value v)]) + (match pt + [(tc-result1: (Param: a b)) + (check-below vt a) + (loop (cddr args))] + [(tc-result1: t) + (tc-error/expr #:return (or expected (ret Univ)) "expected Parameter, but got ~a" t) + (loop (cddr args))]))))] + ;; use the additional but normally ignored first argument to make-sequence + ;; to provide a better instantiation + [(#%plain-app (~var op (id-from 'make-sequence 'racket/private/for)) + (~and quo (quote (i:id ...))) arg:expr) + #:when (andmap type-annotation (syntax->list #'(i ...))) + (match (single-value #'op) + [(tc-result1: (and t Poly?)) + (tc-expr/check #'quo (ret Univ)) + (tc/funapp #'op #'(quo arg) + (ret (instantiate-poly t (extend (list Univ Univ) + (map type-annotation (syntax->list #'(i ...))) + Univ))) + (list (ret Univ) (single-value #'arg)) + expected)])] + ;; special-case for not - flip the filters + [(#%plain-app (~or false? not) arg) + (match (single-value #'arg) + [(tc-result1: t (FilterSet: f+ f-) _) + (ret -Boolean (make-FilterSet f- f+))])] + ;; special case for (current-contract-region)'s default expansion + ;; just let it through without any typechecking, since module-name-fixup + ;; is a private function from syntax/location, so this must have been + ;; (quote-module-name) originally. + [(#%plain-app op src path) + #:declare op (id-from 'module-name-fixup 'syntax/location) + (ret Univ)] + ;; special case for `delay' + [(#%plain-app + mp1 + (#%plain-lambda () + (#%plain-app mp2 (#%plain-app call-with-values (#%plain-lambda () e) list)))) + #:declare mp1 (id-from 'make-promise 'racket/promise) + #:declare mp2 (id-from 'make-promise 'racket/promise) + (ret (-Promise (tc-expr/t #'e)))] + + + [_ #f])) diff --git a/collects/typed-racket/typecheck/typechecker.rkt b/collects/typed-racket/typecheck/typechecker.rkt index 80cd76bc..a4bcf1e2 100644 --- a/collects/typed-racket/typecheck/typechecker.rkt +++ b/collects/typed-racket/typecheck/typechecker.rkt @@ -13,6 +13,7 @@ "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" @@ -24,4 +25,4 @@ (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-objects@ tc-app-eq@ tc-app-lambda@ tc-app-special@))