From b45d2f1a0c627d525c85ddca503bcb41d2b2721c Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 4 May 2010 16:52:20 -0400 Subject: [PATCH] handle full generality of extend-parameterization original commit: 4984345657eda9736b458cf73f97996e3da1ce95 --- collects/typed-scheme/typecheck/tc-app.rkt | 18 ++++++++++++++++-- 1 file changed, 16 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-app.rkt b/collects/typed-scheme/typecheck/tc-app.rkt index dcaca4d2..ead820ab 100644 --- a/collects/typed-scheme/typecheck/tc-app.rkt +++ b/collects/typed-scheme/typecheck/tc-app.rkt @@ -20,7 +20,7 @@ (r:infer infer) (for-template (only-in '#%kernel [apply k:apply]) - "internal-forms.ss" scheme/base scheme/bool + "internal-forms.ss" scheme/base scheme/bool '#%paramz (only-in racket/private/class-internal make-object do-make-object))) (import tc-expr^ tc-lambda^ tc-dots^ tc-let^) @@ -425,7 +425,21 @@ (syntax-parse form #:literals (#%plain-app #%plain-lambda letrec-values quote values apply k:apply not list list* call-with-values do-make-object make-object cons - andmap ormap reverse) + andmap ormap reverse extend-parameterization) + [(#%plain-app extend-parameterization pmz args ...) + (let loop ([args (syntax->list #'(args ...))]) + (if (null? args) 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 #:ret (or expected (ret Univ)) "expected Parameter, but got ~a" t) + (loop (cddr args))]))))] ;; call-with-values [(#%plain-app call-with-values prod con) (match (tc/funapp #'prod #'() (single-value #'prod) null #f)