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

Split out special cases for apply and values from tc-app.rkt.

Browse Source 
original commit: 603442347247c55f59f95af94bc2b05d0875d827
This commit is contained in:
Eric Dobson 2012-08-15 23:28:08 -07:00 committed by Sam Tobin-Hochstadt
parent 536b374ec2
commit bd178b777a
5 changed files with 103 additions and 49 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -37,6 +37,12 @@
(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-apply^
([cond-contracted tc/apply (syntax? syntax? . -> . tc-results?)]))

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

@ -11,7 +11,6 @@
racket/unsafe/ops
(only-in racket/private/class-internal do-make-object)
(only-in syntax/location module-name-fixup)
(only-in '#%kernel [apply k:apply])
;; end fixme
(for-syntax syntax/parse racket/base (utils tc-utils))
(private type-annotation)
@ -24,12 +23,12 @@
'#%paramz
(for-template
racket/unsafe/ops racket/fixnum racket/flonum
(only-in '#%kernel [apply k:apply])
"internal-forms.rkt" racket/base racket/bool '#%paramz
(only-in racket/private/class-internal do-make-object)
(only-in syntax/location module-name-fixup)))
(import tc-expr^ tc-lambda^ tc-let^ tc-apply^ tc-app-hetero^ tc-app-list^)
(import tc-expr^ tc-lambda^ tc-let^ tc-apply^
tc-app-hetero^ tc-app-list^ tc-app-apply^ tc-app-values^)
(export tc-app^)
@ -268,9 +267,11 @@
(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)
(syntax-parse form
#:literals (#%plain-app #%plain-lambda letrec-values quote
values apply k:apply not false? list call-with-values
not false? list
do-make-object module-name-fixup cons
extend-parameterization)
;; bail out immediately if we have one of these
@ -303,11 +304,6 @@
Univ)))
(list (ret Univ) (single-value #'arg))
expected)])]
;; call-with-values
[(#%plain-app call-with-values prod con)
(match (tc/funapp #'prod #'() (single-value #'prod) null #f)
[(tc-results: ts fs os)
(tc/funapp #'con #'(prod) (single-value #'con) (map ret ts fs os) expected)])]
;; in eq? cases, call tc/eq
[(#%plain-app eq?:comparator v1 v2)
;; make sure the whole expression is type correct
@ -322,45 +318,6 @@
(match (single-value #'arg)
[(tc-result1: t (FilterSet: f+ f-) _)
(ret -Boolean (make-FilterSet f- f+))])]
;; (apply values l) gets special handling
[(#%plain-app apply values e)
(match (single-value #'e)
[(tc-result1: (ListDots: dty dbound)) (values->tc-results (make-ValuesDots null dty dbound) #f)]
[(tc-result1: (List: ts)) (ret ts)]
[_ (tc/apply #'values #'(e))])]
;; rewrite this so that it takes advantages of all the special cases
[(#%plain-app k:apply . args)
(tc/app/internal (syntax/loc form (#%plain-app apply . args)) expected)]
;; handle apply specially
[(#%plain-app apply f . args) (tc/apply #'f #'args)]
;; special case for `values' with single argument
;; we just ignore the values, except that it forces arg to return one value
[(#%plain-app values arg)
(match expected
[#f (single-value #'arg)]
[(tc-result1: tp)
(single-value #'arg expected)]
[(tc-results: ts)
(single-value #'arg) ;Type check the argument, to find other errors
(tc-error/expr #:return expected
"wrong number of values: expected ~a but got one"
(length ts))])]
;; handle `values' specially
[(#%plain-app values . args)
(match expected
[(tc-results: ets efs eos)
(match-let ([(list (tc-result1: ts fs os) ...)
(for/list ([arg (syntax->list #'args)]
[et ets] [ef efs] [eo eos])
(single-value arg (ret et ef eo)))])
(if (= (length ts) (length ets) (length (syntax->list #'args)))
(ret ts fs os)
(tc-error/expr #:return expected "wrong number of values: expected ~a but got ~a"
(length ets) (length (syntax->list #'args)))))]
[_ (match-let ([(list (tc-result1: ts fs os) ...)
(for/list ([arg (syntax->list #'args)])
(single-value arg))])
(ret ts fs os))])]
;; special case for keywords
[(#%plain-app
(#%plain-app cpce s-kp fn kpe kws num)

37
collects/typed-racket/typecheck/tc-app/tc-app-apply.rkt Normal file
View File

@ -0,0 +1,37 @@
#lang racket/unit
(require "../../utils/utils.rkt"
syntax/parse racket/match
(typecheck signatures tc-app-helper tc-funapp check-below tc-subst)
(types abbrev utils)
(rep type-rep)
;; fixme - don't need to be bound in this phase - only to make tests work
(only-in '#%kernel [apply k:apply])
;; end fixme
(for-template
racket/base
(only-in '#%kernel [apply k:apply])))
(import tc-expr^ tc-apply^)
(export tc-app-apply^)
(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)]
;; (apply values l) gets special handling
;; Needs to be above the general apply checking
[(#%plain-app apply values e)
(match (single-value #'e)
[(tc-result1: (ListDots: dty dbound)) (values->tc-results (make-ValuesDots null dty dbound) #f)]
[(tc-result1: (List: ts)) (ret ts)]
[_ (tc/apply #'values #'(e))])]
;; handle apply specially
[(#%plain-app apply f . args) (tc/apply #'f #'args)]
[_ #f]))

52
collects/typed-racket/typecheck/tc-app/tc-app-values.rkt Normal file
View File

@ -0,0 +1,52 @@
#lang racket/unit
(require "../../utils/utils.rkt"
syntax/parse racket/match
(typecheck signatures tc-app-helper tc-funapp check-below)
(types abbrev utils)
(rep type-rep)
(for-template racket/base))
(import tc-expr^)
(export tc-app-values^)
(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)
[(tc-results: ts fs os)
(tc/funapp #'con #'(prod) (single-value #'con) (map ret ts fs os) expected)])]
;; special case for `values' with single argument
;; we just ignore the values, except that it forces arg to return one value
[(#%plain-app values arg)
(match expected
[#f (single-value #'arg)]
[(tc-result1: tp)
(single-value #'arg expected)]
[(tc-results: ts)
(single-value #'arg) ;Type check the argument, to find other errors
(tc-error/expr #:return expected
"wrong number of values: expected ~a but got one"
(length ts))])]
;; handle `values' specially
[(#%plain-app values . args)
(match expected
[(tc-results: ets efs eos)
(match-let ([(list (tc-result1: ts fs os) ...)
(for/list ([arg (syntax->list #'args)]
[et ets] [ef efs] [eo eos])
(single-value arg (ret et ef eo)))])
(if (= (length ts) (length ets) (length (syntax->list #'args)))
(ret ts fs os)
(tc-error/expr #:return expected "wrong number of values: expected ~a but got ~a"
(length ets) (length (syntax->list #'args)))))]
[_ (match-let ([(list (tc-result1: ts fs os) ...)
(for/list ([arg (syntax->list #'args)])
(single-value arg))])
(ret ts fs os))])]
[_ #f]))

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

@ -6,8 +6,10 @@
provide-signature-elements
define-values/invoke-unit/infer link)
"signatures.rkt"
"tc-app/tc-app-apply.rkt"
"tc-app/tc-app-hetero.rkt"
"tc-app/tc-app-list.rkt"
"tc-app/tc-app-values.rkt"
"signatures.rkt"
"tc-if.rkt" "tc-lambda-unit.rkt" "tc-app.rkt"
"tc-let-unit.rkt" "tc-apply.rkt"
@ -17,4 +19,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-hetero@ tc-app-list@ tc-app-apply@ tc-app-values@))