suzanne.soy/typed-racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Cleanup of tc-app refactor.

Browse Source 
original commit: 7005f12f0dbb744442118d539c807c7bc2f4b003
This commit is contained in:
Eric Dobson 2012-08-16 23:05:38 -07:00 committed by Sam Tobin-Hochstadt
parent 543b1e3069
commit 09e0c07537
14 changed files with 83 additions and 90 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
collects/typed-racket/typecheck/signatures.rkt
View File

@ -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?)]))

5
collects/typed-racket/typecheck/tc-app-helper.rkt
View File

@ -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?)

43
collects/typed-racket/typecheck/tc-app.rkt
View File

@ -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)

36
collects/typed-racket/typecheck/tc-app/signatures.rkt Normal file
View File

@ -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]))

4
collects/typed-racket/typecheck/tc-app/tc-app-apply.rkt
View File

@ -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)]

9
collects/typed-racket/typecheck/tc-app/tc-app-eq.rkt
View File

@ -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^)

4
collects/typed-racket/typecheck/tc-app/tc-app-hetero.rkt
View File

@ -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)

2
collects/typed-racket/typecheck/tc-app/tc-app-keywords.rkt
View File

@ -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

3
collects/typed-racket/typecheck/tc-app/tc-app-lambda.rkt
View File

@ -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)

4
collects/typed-racket/typecheck/tc-app/tc-app-list.rkt
View File

@ -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

3
collects/typed-racket/typecheck/tc-app/tc-app-objects.rkt
View File

@ -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)

10
collects/typed-racket/typecheck/tc-app/tc-app-special.rkt
View File

@ -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^)

4
collects/typed-racket/typecheck/tc-app/tc-app-values.rkt
View File

@ -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)

18
collects/typed-racket/typecheck/typechecker.rkt
View File

@ -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@))