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

rationalize get-type/infer to handle tc-results.

Browse Source 
Fix tc-let to handle tc-results in various places.

svn: r14796

original commit: a3fb3575f9daccccc8ec053d585f3e8e9e192748
This commit is contained in:
Sam Tobin-Hochstadt 2009-05-13 16:16:39 +00:00
commit d825cc12d7
2 changed files with 26 additions and 47 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
collects/typed-scheme/private/type-annotation.ss
View File

@ -4,8 +4,9 @@
(require (rep type-rep)
(utils tc-utils)
(env type-env)
(types subtype union convenience resolve)
(except-in (types subtype union convenience resolve utils) -> ->*)
(private parse-type)
(only-in scheme/contract listof ->)
scheme/match mzlib/trace)
(provide type-annotation
get-type
@ -89,40 +90,38 @@
(define (get-types stxs #:default [default #f])
(map (lambda (e) (get-type e #:default default)) stxs))
;; get the type annotations on this list of identifiers
;; if not all identifiers have annotations, return the supplied inferred type
;; list[identifier] type -> list[type]
(define (get-type/infer stxs expr tc-expr tc-expr/check)
;; list[identifier] stx (stx -> tc-results?) (stx tc-results? -> tc-results?) -> tc-results?
(d/c (get-type/infer stxs expr tc-expr tc-expr/check)
((listof identifier?) syntax? (syntax? . -> . tc-results?) (syntax? tc-results? . -> . tc-results?) . -> . tc-results?)
(match stxs
['()
(tc-expr/check expr (-values null))
(list)]
(tc-expr/check expr (ret null))]
[(list stx)
(cond [(type-annotation stx #:infer #t)
=> (lambda (ann)
(list (tc-expr/check expr ann)))]
[else (list (tc-expr expr))])]
(tc-expr/check expr (ret ann)))]
[else (tc-expr expr)])]
[(list stx ...)
(let ([anns (for/list ([s stxs]) (type-annotation s #:infer #t))])
(if (for/and ([a anns]) a)
(begin (tc-expr/check expr (-values anns)) anns)
(begin (tc-expr/check expr (ret anns)))
(let ([ty (tc-expr expr)])
(match ty
[(Values: tys)
[(tc-results: tys)
(if (not (= (length stxs) (length tys)))
(begin
(tc-error/delayed
"Expression should produce ~a values, but produces ~a values of types ~a"
(length stxs) (length tys) (stringify tys))
(map (lambda _ (Un)) stxs))
(map (lambda (stx ty a)
(cond [a => (lambda (ann) (check-type stx ty ann) #;(log/extra stx ty ann) ann)]
[else #;(log/noann stx ty) ty]))
stxs tys anns))]
(ret (map (lambda _ (Un)) stxs)))
(ret
(for/list ([stx stxs] [ty tys] [a anns])
(cond [a => (lambda (ann) (check-type stx ty ann) ann)]
[else ty]))))]
[ty (tc-error/delayed
"Expression should produce ~a values, but produces one values of type ~a"
(length stxs) ty)
(map (lambda _ (Un)) stxs)]))))]))
(ret (map (lambda _ (Un)) stxs))]))))]))
;; check that e-type is compatible with ty in context of stx

40
collects/typed-scheme/typecheck/tc-let-unit.ss
View File

@ -34,27 +34,6 @@
(tc-exprs/check (syntax->list body) expected)
(tc-exprs (syntax->list body)))))
#|
;; this is more abstract, but sucks
(define ((mk f) namess exprs body form)
(let* ([names (map syntax->list (syntax->list namess))]
[exprs (syntax->list exprs)])
(f (lambda (e->t namess types exprs) (do-check e->t namess types form exprs body)) names exprs)))
(define tc/letrec-values
(mk (lambda (do names exprs)
(let ([types (map (lambda (l) (map get-type l)) names)])
(do tc-expr/t names types exprs)))))
(define tc/let-values
(mk (lambda (do names exprs)
(let* (;; the types of the exprs
[inferred-types (map tc-expr/t exprs)]
;; the annotated types of the name (possibly using the inferred types)
[types (map get-type/infer names inferred-types)])
(do (lambda (x) x) names types inferred-types)))))
|#
(define (tc/letrec-values/check namess exprs body form expected)
(tc/letrec-values/internal namess exprs body form expected))
@ -72,8 +51,7 @@
(andmap values expecteds)
(tc-expr/check e (mk expecteds))
(tc-expr e)))
(match tcr
[(tc-result1: t) t]))
tcr)
(define (tc/letrec-values/internal namess exprs body form expected)
(let* ([names (map syntax->list (syntax->list namess))]
@ -100,8 +78,9 @@
;; then check this expression separately
(with-lexical-env/extend
(list (car names))
(list (get-type/infer (car names) (car exprs) (lambda (e) (tc-expr/maybe-expected/t e (car names)))
(lambda (e t) (tc-expr/check/t e (ret t)))))
(list (match (get-type/infer (car names) (car exprs) (lambda (e) (tc-expr/maybe-expected/t e (car names)))
tc-expr/check)
[(tc-results: ts) ts]))
(loop (cdr names) (cdr exprs) (apply append (cdr names)) (cdr clauses)))]
[else
;(for-each (lambda (vs) (for-each (lambda (v) (printf/log "Letrec Var: ~a~n" (syntax-e v))) vs)) names)
@ -115,9 +94,8 @@
[(#%plain-lambda () _)
(and expected (syntax-property e 'typechecker:called-in-tail-position))
(begin
(tc-expr/check e (-> expected))
(-> expected))]
[_ (tc-expr/t e)]))
(tc-expr/check e (ret (-> expected))))]
[_ (tc-expr e)]))
(define (tc/let-values namess exprs body form [expected #f])
(let* (;; a list of each name clause
@ -127,8 +105,10 @@
;; the types of the exprs
#;[inferred-types (map (tc-expr-t/maybe-expected expected) exprs)]
;; the annotated types of the name (possibly using the inferred types)
[types (for/list ([name names] [e exprs]) (get-type/infer name e (tc-expr-t/maybe-expected expected)
(lambda (e t) (tc-expr/check/t e (ret t)))))]
[types (for/list ([name names] [e exprs])
(match (get-type/infer name e (tc-expr-t/maybe-expected expected)
tc-expr/check)
[(tc-results: ts) ts]))]
;; the clauses for error reporting
[clauses (syntax-case form () [(lv cl . b) (syntax->list #'cl)])])
(do-check void names types form types body clauses expected)))