diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt index c351c4ef..4753cc03 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-subforms-unit.rkt @@ -21,19 +21,6 @@ ;; get called with the wrong kind of arguments by the exception ;; mechanism. The right thing is to use the exception predicate. -(define (transpose l) (apply map list l)) - -;; combine-types : Values * -> tc-results -(define (combine-types . args) - (match args - [(list (tc-results: tss) ...) - (unless (apply = (map length tss)) - (tc-error "Exception handlers and body did not all have the same number of results: ~a" (map length tss))) - ;; transpose and union - (let ([ts* (transpose tss)]) - (ret (map (lambda (ts) (apply Un ts)) ts*)))] - [_ (int-err "Internal error: unsupported exception result type in: ~a" args)])) - ;; Does a depth first search of the syntax object. For each sub object it attempts to match it ;; against the provide syntax-parse patterns. (define-syntax find-syntax @@ -52,15 +39,14 @@ [_ (void)])))])) ;; find the subexpressions that need to be typechecked in an ignored form -;; syntax -> any -(define (check-subforms/with-handlers form [expected #f]) - (define handler-tys '()) - (define body-ty #f) - (define body-stx #f) +;; syntax (or/c #f tc-results/c) -> full-tc-results/c +(define (check-subforms/with-handlers form expected) + (define handler-results '()) + (define body-results #f) ;; tc-result1 -> tc-results ;; The result of applying the function to a single argument of the type of its first argument ;; FIXME: This is the wrong type, see above fixme - (define (get-result-ty t) + (define (get-range-result t) (let loop ((t t)) (match t [(Function: (list _ ... (arr: (list arg1) _ _ #f (list (Keyword: _ _ #f) ...)) _ ...)) @@ -81,28 +67,11 @@ [stx:exn-handler^ (match (single-value #'stx) [(tc-result1: t) - (set! handler-tys (cons (get-result-ty t) handler-tys))])] - ;; this is the body of the with-handlers - [stx:exn-body^ - (set! body-stx #'stx) - (set! body-ty (tc-expr #'stx))]) - (apply combine-types body-ty handler-tys)) - -;; syntax tc-results -> tc-results -(define (check-subforms/with-handlers/check form expected) - (define body-results #f) - (find-syntax form - ;; if this needs to be checked - [stx:with-type^ - ;; the form should be already ascribed the relevant type - (tc-expr #'stx)] - ;; this is a handler function - [stx:exn-handler^ - (tc-expr/check #'stx (ret (-> (Un) (tc-results->values expected))))] + (set! handler-results (cons (get-range-result t) handler-results))])] ;; this is the body of the with-handlers [stx:exn-body^ (set! body-results (tc-expr/check #'stx expected))]) - body-results) + (merge-tc-results (cons body-results handler-results))) ;; typecheck the expansion of a with-handlers form ;; syntax -> void diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/signatures.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/signatures.rkt index c0f9a213..44df9389 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/signatures.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/signatures.rkt @@ -15,8 +15,7 @@ (define-signature check-subforms^ ([cond-contracted check-subforms/ignore (syntax? . -> . void?)] - [cond-contracted check-subforms/with-handlers (syntax? . -> . full-tc-results/c)] - [cond-contracted check-subforms/with-handlers/check (syntax? tc-results/c . -> . full-tc-results/c)])) + [cond-contracted check-subforms/with-handlers (syntax? (or/c tc-results/c #f) . -> . full-tc-results/c)])) (define-signature check-class^ ([cond-contracted check-class (syntax? (or/c tc-results/c #f) . -> . full-tc-results/c)])) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt index 189076ce..557ffbba 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt @@ -91,9 +91,7 @@ (check-class form expected)] [stx:exn-handlers^ (register-ignored! form) - (if expected - (check-subforms/with-handlers/check form expected) - (check-subforms/with-handlers form))] + (check-subforms/with-handlers form expected) ] ;; explicit failure [t:typecheck-failure (explicit-fail #'t.stx #'t.message #'t.var)] diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/optimizer/tests/vector-length-impersonator.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/optimizer/tests/vector-length-impersonator.rkt index c3517da0..51dd0365 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/optimizer/tests/vector-length-impersonator.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/optimizer/tests/vector-length-impersonator.rkt @@ -16,7 +16,7 @@ END ;; should error (with-handlers ([exn:fail:contract? - (lambda (e) + (lambda: ([e : exn]) (when (regexp-match "index is out of range for empty vector" (exn-message e)) (display "passed\n")))]) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/pr12644.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/pr12644.rkt index 6c58ddbb..5c370713 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/pr12644.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/succeed/pr12644.rkt @@ -7,13 +7,11 @@ (: g (All (x) (x -> x))) (define (g x) x) -(: v (Listof (U inf Byte))) +(: v (Listof (U inf Number))) (define v (list - (with-handlers ((void values)) 2) (with-handlers ((void add1)) 3) - (with-handlers ((void f)) 4) - (with-handlers ((void g)) 5))) + (with-handlers ((void f)) 4))) (list diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/special-env-typecheck-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/special-env-typecheck-tests.rkt index ef139a00..5de1ce79 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/special-env-typecheck-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/special-env-typecheck-tests.rkt @@ -118,7 +118,8 @@ ;; exception handling [tc-e (with-handlers ([void (λ (x) (values 0 0))]) (values "" "")) - #:ret (ret (list (t:Un -Zero -String) (t:Un -Zero -String)))] + #:ret (ret (list (t:Un -Zero -String) (t:Un -Zero -String)) + (list -true-filter -true-filter))] (tc-e (make-temporary-file) -Path) (tc-e (make-temporary-file "ee~a") -Path) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt index a3f1b32f..9bf2359f 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/typecheck-tests.rkt @@ -2947,6 +2947,12 @@ #:ret (ret -Nat -true-filter) #:expected (ret -Nat -no-filter)] + [tc-e + (with-handlers ([exn:fail? (λ (exn) #f)]) + 5) + #:ret (ret Univ -top-filter) + #:expected (ret Univ -no-filter)] + [tc-e (lambda (a . b) (apply values a b))