From bd178b777af188b2588cba7c5e4fa9ef6606c5e8 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Wed, 15 Aug 2012 23:28:08 -0700 Subject: [PATCH] Split out special cases for apply and values from tc-app.rkt. original commit: 603442347247c55f59f95af94bc2b05d0875d827 --- .../typed-racket/typecheck/signatures.rkt | 6 +++ collects/typed-racket/typecheck/tc-app.rkt | 53 ++----------------- .../typecheck/tc-app/tc-app-apply.rkt | 37 +++++++++++++ .../typecheck/tc-app/tc-app-values.rkt | 52 ++++++++++++++++++ .../typed-racket/typecheck/typechecker.rkt | 4 +- 5 files changed, 103 insertions(+), 49 deletions(-) create mode 100644 collects/typed-racket/typecheck/tc-app/tc-app-apply.rkt create mode 100644 collects/typed-racket/typecheck/tc-app/tc-app-values.rkt diff --git a/collects/typed-racket/typecheck/signatures.rkt b/collects/typed-racket/typecheck/signatures.rkt index 2e7fd618..a2bbcc7c 100644 --- a/collects/typed-racket/typecheck/signatures.rkt +++ b/collects/typed-racket/typecheck/signatures.rkt @@ -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?)])) diff --git a/collects/typed-racket/typecheck/tc-app.rkt b/collects/typed-racket/typecheck/tc-app.rkt index dbf96727..fe40af5f 100644 --- a/collects/typed-racket/typecheck/tc-app.rkt +++ b/collects/typed-racket/typecheck/tc-app.rkt @@ -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) diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-apply.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-apply.rkt new file mode 100644 index 00000000..1c699109 --- /dev/null +++ b/collects/typed-racket/typecheck/tc-app/tc-app-apply.rkt @@ -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])) + diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-values.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-values.rkt new file mode 100644 index 00000000..df09e3eb --- /dev/null +++ b/collects/typed-racket/typecheck/tc-app/tc-app-values.rkt @@ -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])) diff --git a/collects/typed-racket/typecheck/typechecker.rkt b/collects/typed-racket/typecheck/typechecker.rkt index d1cdafa3..6c581aa4 100644 --- a/collects/typed-racket/typecheck/typechecker.rkt +++ b/collects/typed-racket/typecheck/typechecker.rkt @@ -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@))