From 6d1257e624f6165003af3ddb53d8a3fdf91a14ce Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 19 May 2009 16:27:44 +0000 Subject: [PATCH] Pass the right argument to unfold. Fix tc/rec-lambda/check for tc-results in appropriate places. svn: r14871 --- collects/typed-scheme/typecheck/signatures.ss | 2 +- collects/typed-scheme/typecheck/tc-app.ss | 10 ++++++---- collects/typed-scheme/typecheck/tc-lambda-unit.ss | 9 +++++---- 3 files changed, 12 insertions(+), 9 deletions(-) diff --git a/collects/typed-scheme/typecheck/signatures.ss b/collects/typed-scheme/typecheck/signatures.ss index e902aa2463..a1031cf6f9 100644 --- a/collects/typed-scheme/typecheck/signatures.ss +++ b/collects/typed-scheme/typecheck/signatures.ss @@ -32,7 +32,7 @@ (define-signature tc-lambda^ ([cnt tc/lambda (syntax? syntax? syntax? . -> . tc-results?)] [cnt tc/lambda/check (syntax? syntax? syntax? tc-results? . -> . tc-results?)] - [cnt tc/rec-lambda/check (syntax? syntax? syntax? syntax? (listof Type/c) Type/c . -> . Type/c)])) + [cnt tc/rec-lambda/check (syntax? syntax? syntax? syntax? (listof Type/c) tc-results? . -> . tc-results?)])) (define-signature tc-app^ ([cnt tc/app (syntax? . -> . tc-results?)] diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index 21ec4c0684..aa98361614 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -100,7 +100,7 @@ [name-assoc (map list names (syntax->list named-args))]) (let loop ([t (tc-expr cl)]) (match t - [(tc-result1: (? Mu? t)) (loop (ret (unfold t)))] + [(tc-result1: (? Mu? t*)) (loop (ret (unfold t*)))] [(tc-result1: (and c (Class: pos-tys (list (and tnflds (list tnames _ _)) ...) _))) (unless (= (length pos-tys) (length (syntax->list pos-args))) @@ -151,10 +151,12 @@ (generalize (tc-expr/t ac))))] [ts (cons ts1 ann-ts)]) ;; check that the actual arguments are ok here - (map tc-expr/check (syntax->list #'(actuals ...)) ann-ts) + (for/list ([a (syntax->list #'(actuals ...))] + [t ann-ts]) + (tc-expr/check a (ret t))) ;; then check that the function typechecks with the inferred types (tc/rec-lambda/check form args body lp ts expected) - (ret expected))] + expected)] ;; special case when argument needs inference [_ (let ([ts (for/list ([ac (syntax->list actuals)] @@ -163,7 +165,7 @@ (type-annotation f #:infer #t) (generalize (tc-expr/t ac))))]) (tc/rec-lambda/check form args body lp ts expected) - (ret expected))])) + expected)])) (define (tc/apply f args) (define (do-ret t) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index 551a78ab7f..3fb1baae4e 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -197,7 +197,7 @@ (= 1 (length (syntax->list formals)))) (let loop ([expected expected]) (match expected - [(tc-result1: (Mu: _ _)) (loop (unfold expected))] + [(tc-result1: (and t (Mu: _ _))) (loop (ret (unfold t)))] [(tc-result1: (Function: (list (arr: argss rets rests drests '()) ...))) (for/list ([args argss] [ret rets] [rest rests] [drest drests]) (tc/lambda-clause/check (car (syntax->list formals)) (car (syntax->list bodies)) @@ -299,14 +299,15 @@ ;; name : the name of the loop ;; args : the types of the actual arguments to the loop ;; ret : the expected return type of the whole expression -(define (tc/rec-lambda/check form formals body name args ret) +(define (tc/rec-lambda/check form formals body name args return) (with-lexical-env/extend (syntax->list formals) args - (let* ([t (make-arr args ret)] + (let* ([r (tc-results->values return)] + [t (make-arr args r)] [ft (make-Function (list t))]) (with-lexical-env/extend (list name) (list ft) - (begin (tc-exprs/check (syntax->list body) ret) ft))))) + (begin (tc-exprs/check (syntax->list body) return) (ret ft)))))) ;(trace tc/mono-lambda)