From dec8803f271fa1b4a2401b186c80e78b04739ed5 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Fri, 14 Aug 2009 20:27:53 +0000 Subject: [PATCH] when result type is dotted, pass it through tc-expr/check svn: r15737 original commit: 5174bbb5f062011c2edfe7a0403071055830f55f --- collects/typed-scheme/typecheck/tc-app.ss | 3 ++- collects/typed-scheme/typecheck/tc-expr-unit.ss | 9 +++++---- collects/typed-scheme/typecheck/tc-lambda-unit.ss | 7 ++++--- 3 files changed, 11 insertions(+), 8 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-app.ss b/collects/typed-scheme/typecheck/tc-app.ss index f2c37f07..6e4c884f 100644 --- a/collects/typed-scheme/typecheck/tc-app.ss +++ b/collects/typed-scheme/typecheck/tc-app.ss @@ -172,7 +172,8 @@ (define (do-ret t) (match t [(Values: (list (Result: ts _ _) ...)) (ret ts)] - [(ValuesDots: (list (Result: ts _ _) ...) dty dbound) (ret ts (for/list ([t ts]) (-FS null null)) (for/list ([t ts]) (make-Empty)) dty dbound)])) + [(ValuesDots: (list (Result: ts _ _) ...) dty dbound) (ret ts (for/list ([t ts]) (-FS null null)) (for/list ([t ts]) (make-Empty)) dty dbound)] + [_ (int-err "do-ret fails: ~a" t)])) (define f-ty (single-value f)) ;; produces the first n-1 elements of the list, and the last element (define (split l) (let-values ([(f r) (split-at l (sub1 (length l)))]) diff --git a/collects/typed-scheme/typecheck/tc-expr-unit.ss b/collects/typed-scheme/typecheck/tc-expr-unit.ss index 51e18385..046cb66c 100644 --- a/collects/typed-scheme/typecheck/tc-expr-unit.ss +++ b/collects/typed-scheme/typecheck/tc-expr-unit.ss @@ -190,7 +190,8 @@ [((? Type? t1) (? Type? t2)) (unless (subtype t1 t2) (tc-error/expr "Expected ~a, but got ~a" t2 t1)) - expected])) + expected] + [(a b) (int-err "unexpected input for check-below: ~a ~a" a b)])) (define (tc-expr/check/type form expected) #;(syntax? Type/c . -> . tc-results?) @@ -205,13 +206,13 @@ ;; typecheck form (let ([ty (cond [(type-ascription form) => (lambda (ann) (let ([r (tc-expr/check/internal form ann)]) - (check-below r expected) - #;expected))] + (check-below r expected)))] [else (tc-expr/check/internal form expected)])]) (match ty [(tc-results: ts fs os) (let ([ts* (do-inst form ts)]) - (ret ts* fs os))])))) + (ret ts* fs os))] + [_ ty])))) ;; tc-expr/check : syntax tc-results -> tc-results (define (tc-expr/check/internal form expected) diff --git a/collects/typed-scheme/typecheck/tc-lambda-unit.ss b/collects/typed-scheme/typecheck/tc-lambda-unit.ss index 82064cc8..6cfe6e0c 100644 --- a/collects/typed-scheme/typecheck/tc-lambda-unit.ss +++ b/collects/typed-scheme/typecheck/tc-lambda-unit.ss @@ -66,8 +66,8 @@ (define (check-body) (with-lexical-env/extend arg-list arg-types - (make lam-result (map list arg-list arg-types) null rest-ty drest - (tc-exprs/check (syntax->list body) ret-ty)))) + (make-lam-result (map list arg-list arg-types) null rest-ty drest + (tc-exprs/check (syntax->list body) ret-ty)))) (when (or (not (= arg-len tys-len)) (and (or rest-ty drest) (not rest))) (tc-error/delayed (expected-str tys-len rest-ty drest arg-len rest))) @@ -221,7 +221,8 @@ [(tc-result1: (Function: _)) (tc/mono-lambda/type formals bodies expected)] [(tc-result1: (or (Poly: _ _) (PolyDots: _ _))) (tc/plambda form formals bodies expected)] - [(tc-result1: (Error:)) (tc/mono-lambda/type formals bodies #f)])) + [(tc-result1: (Error:)) (tc/mono-lambda/type formals bodies #f)] + [_ (int-err "expected not an appropriate tc-result: ~a" expected)])) (match expected [(tc-result1: (and t (Poly-names: ns expected*))) (let* ([tvars (let ([p (syntax-property form 'typechecker:plambda)])