From a97489cc808544c8080324c1452e86703c7af3e3 Mon Sep 17 00:00:00 2001 From: Brian Lachance Date: Thu, 30 Jul 2015 15:40:34 -0400 Subject: [PATCH] Fix attempt at handling internal errors when binding AnyValues results 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 5e0e8ed713f3d607153a9e0fc1443d7b7bccf79b. --- .../typed-racket/private/type-annotation.rkt | 5 +-- .../typed-racket/typecheck/tc-let-unit.rkt | 36 +++++++------------ .../typed-racket/typecheck/tc-toplevel.rkt | 5 --- 3 files changed, 15 insertions(+), 31 deletions(-) diff --git a/typed-racket-lib/typed-racket/private/type-annotation.rkt b/typed-racket-lib/typed-racket/private/type-annotation.rkt index a3c8bb17..4136393b 100644 --- a/typed-racket-lib/typed-racket/private/type-annotation.rkt +++ b/typed-racket-lib/typed-racket/private/type-annotation.rkt @@ -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))] diff --git a/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt b/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt index 719d1a72..801e96ee 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-let-unit.rkt @@ -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 diff --git a/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt b/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt index e4888a20..d2298a73 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-toplevel.rkt @@ -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))])])]