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

Fix attempt at handling internal errors when binding AnyValues results

Browse Source 
This is the correct change for how attempting to bind AnyValues results
caused internal type-checking errors. The root cause was get-type/infer
violating its own contract by using the default return value from
tc-error/expr

This (partially) reverts 5e0e8ed713.
This commit is contained in:
Brian Lachance 2015-07-30 15:40:34 -04:00
parent 5e1334c02e
commit a97489cc80
3 changed files with 15 additions and 31 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
typed-racket-lib/typed-racket/private/type-annotation.rkt
View File

@ -86,8 +86,9 @@
(match res
[(tc-any-results: _)
(tc-error/expr
"Expression should produce ~a values, but produces an unknown number of values"
(length stxs))]
#:return (map (lambda _ (tc-result (Un))) stxs)
"Expression should produce ~a values, but produces an unknown number of values"
(length stxs))]
[(tc-results: (list (== -Bottom)) _ _)
(for/list ([_ (in-range (length stxs))])
(tc-result -Bottom))]

36
typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt
View File

@ -31,9 +31,7 @@
(for/list ([names namess] [results results])
(match results
[(list (tc-result: _ _ os) ...)
(map list names os)]
[(tc-results: (list (== -Bottom)))
(map list names (make-list (length names) -empty-obj))]))))
(map list names os)]))))
;; Checks that the body has the expected type when names are bound to the types spcified by results.
;; The exprs are also typechecked by using expr->type.
@ -76,9 +74,7 @@
(-and (-filter (-val #f) n) f-)))]))))]
;; amk: does this case ever occur?
[(list (tc-result: e-ts (NoFilter:) _) ...)
(values e-ts (make-list (length e-ts) -empty-obj) null)]
[(tc-results: (list (== -Bottom)))
(values (list -Bottom) (list -empty-obj) null)]))))
(values e-ts (make-list (length e-ts) -empty-obj) null)]))))
;; extend the lexical environment for checking the body
;; with types and potential aliases
(with-lexical-env/extend-types+aliases
@ -93,9 +89,7 @@
(for ([expr (in-list exprs)] [results (in-list expected-results)])
(match results
[(list (tc-result: ts fs os) ...)
(expr->type expr (ret ts fs os))]
[(tc-results: (list (== -Bottom)))
(list expr -Bottom -empty-obj)]))
(expr->type expr (ret ts fs os))]))
;; typecheck the body
(tc-body/check body (and expected (erase-filter expected)))))))
@ -240,21 +234,15 @@
(cond [(null? clauses) (k)]
[else
(match-define (lr-clause names expr) (car clauses))
(match (get-type/infer names expr
(lambda (e) (tc-expr/maybe-expected/t e names))
tc-expr/check)
[(list (tc-result: ts fs os) ...)
(with-lexical-env/extend-types
names
ts
(replace-names (map list names os)
(loop (cdr clauses))))]
[(tc-results: (list (== -Bottom)))
(with-lexical-env/extend-types
names
(make-list (length names) -Bottom)
(replace-names (map list names (make-list (length names) -empty-obj))
(loop (cdr clauses))))])])))
(match-define (list (tc-result: ts fs os) ...)
(get-type/infer names expr
(lambda (e) (tc-expr/maybe-expected/t e names))
tc-expr/check))
(with-lexical-env/extend-types
names
ts
(replace-names (map list names os)
(loop (cdr clauses))))])))
;; this is so match can provide us with a syntax property to
;; say that this binding is only called in tail position

5
typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt
View File

@ -190,11 +190,6 @@
(match (get-type/infer vars #'expr tc-expr tc-expr/check)
[(list (tc-result: ts) ...)
(for/list ([i (in-list vars)] [t (in-list ts)])
(register-type i t)
(free-id-table-set! unann-defs i #t)
(make-def-binding i t))]
[(tc-results: (list (== -Bottom)))
(for/list ([i (in-list vars)] [t (in-cycle (list -Bottom))])
(register-type i t)
(free-id-table-set! unann-defs i #t)
(make-def-binding i t))])])]