Moved last special cases out of tc-app.rkt.
original commit: 54d49d0ec163a149948d2c8337f6de66d1ec3be2
This commit is contained in:
Eric Dobson
Sam Tobin-Hochstadt
parent
5871c0c182
commit
543b1e3069
|
|
@ -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?)]))
|
||||
|
|
|
|||
|
|
@ -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)])
|
||||
|
|
|
|||
73
collects/typed-racket/typecheck/tc-app/tc-app-special.rkt
Normal file
73
collects/typed-racket/typecheck/tc-app/tc-app-special.rkt
Normal file
|
|
@ -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]))
|
||||
|
|
@ -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@))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user