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

Pass the right argument to unfold.

Browse Source 
Fix tc/rec-lambda/check for tc-results in appropriate places.

svn: r14871
This commit is contained in:
Sam Tobin-Hochstadt 2009-05-19 16:27:44 +00:00
parent eedafc034b
commit 6d1257e624
3 changed files with 12 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/typed-scheme/typecheck/signatures.ss
View File

@ -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?)]

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

@ -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)

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

@ -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)