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

when result type is dotted, pass it through tc-expr/check

Browse Source 
svn: r15737
This commit is contained in:
Sam Tobin-Hochstadt 2009-08-14 20:27:53 +00:00
parent 83e0ec2b40
commit 5174bbb5f0
3 changed files with 11 additions and 8 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/typed-scheme/typecheck/tc-app.ss
View File

@ -172,7 +172,8 @@
(define (do-ret t) (define (do-ret t)
(match t (match t
[(Values: (list (Result: ts _ _) ...)) (ret ts)] [(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)) (define f-ty (single-value f))
;; produces the first n-1 elements of the list, and the last element ;; 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)))]) (define (split l) (let-values ([(f r) (split-at l (sub1 (length l)))])

9
collects/typed-scheme/typecheck/tc-expr-unit.ss
View File

@ -190,7 +190,8 @@
[((? Type? t1) (? Type? t2)) [((? Type? t1) (? Type? t2))
(unless (subtype t1 t2) (unless (subtype t1 t2)
(tc-error/expr "Expected ~a, but got ~a" t2 t1)) (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) (define (tc-expr/check/type form expected)
#;(syntax? Type/c . -> . tc-results?) #;(syntax? Type/c . -> . tc-results?)
@ -205,13 +206,13 @@
;; typecheck form ;; typecheck form
(let ([ty (cond [(type-ascription form) => (lambda (ann) (let ([ty (cond [(type-ascription form) => (lambda (ann)
(let ([r (tc-expr/check/internal form ann)]) (let ([r (tc-expr/check/internal form ann)])
(check-below r expected) (check-below r expected)))]
#;expected))]
[else (tc-expr/check/internal form expected)])]) [else (tc-expr/check/internal form expected)])])
(match ty (match ty
[(tc-results: ts fs os) [(tc-results: ts fs os)
(let ([ts* (do-inst form ts)]) (let ([ts* (do-inst form ts)])
(ret ts* fs os))])))) (ret ts* fs os))]
[_ ty]))))
;; tc-expr/check : syntax tc-results -> tc-results ;; tc-expr/check : syntax tc-results -> tc-results
(define (tc-expr/check/internal form expected) (define (tc-expr/check/internal form expected)

7
collects/typed-scheme/typecheck/tc-lambda-unit.ss
View File

@ -66,8 +66,8 @@
(define (check-body) (define (check-body)
(with-lexical-env/extend (with-lexical-env/extend
arg-list arg-types arg-list arg-types
(make lam-result (map list arg-list arg-types) null rest-ty drest (make-lam-result (map list arg-list arg-types) null rest-ty drest
(tc-exprs/check (syntax->list body) ret-ty)))) (tc-exprs/check (syntax->list body) ret-ty))))
(when (or (not (= arg-len tys-len)) (when (or (not (= arg-len tys-len))
(and (or rest-ty drest) (not rest))) (and (or rest-ty drest) (not rest)))
(tc-error/delayed (expected-str tys-len rest-ty drest arg-len 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: (Function: _)) (tc/mono-lambda/type formals bodies expected)]
[(tc-result1: (or (Poly: _ _) (PolyDots: _ _))) [(tc-result1: (or (Poly: _ _) (PolyDots: _ _)))
(tc/plambda form formals bodies expected)] (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 (match expected
[(tc-result1: (and t (Poly-names: ns expected*))) [(tc-result1: (and t (Poly-names: ns expected*)))
(let* ([tvars (let ([p (syntax-property form 'typechecker:plambda)]) (let* ([tvars (let ([p (syntax-property form 'typechecker:plambda)])