diff --git a/typed-racket-lib/typed-racket/base-env/prims-contract.rkt b/typed-racket-lib/typed-racket/base-env/prims-contract.rkt index b063fe4c..605489a3 100644 --- a/typed-racket-lib/typed-racket/base-env/prims-contract.rkt +++ b/typed-racket-lib/typed-racket/base-env/prims-contract.rkt @@ -281,9 +281,7 @@ (λ () (define type-stx (or (cast-table-ref id) - (int-err (string-append - "contract-def-property: thunk called too early\n" - " This should only be called after the type-checking pass has finished.")))) + #f)) `#s(contract-def ,type-stx ,flat? ,maker? typed)))) diff --git a/typed-racket-lib/typed-racket/private/type-contract.rkt b/typed-racket-lib/typed-racket/private/type-contract.rkt index 9f8e8229..d8bb9899 100644 --- a/typed-racket-lib/typed-racket/private/type-contract.rkt +++ b/typed-racket-lib/typed-racket/private/type-contract.rkt @@ -9,7 +9,7 @@ (utils tc-utils) (env type-name-env row-constraint-env) (rep core-rep rep-utils type-mask values-rep) - (types resolve union utils printer) + (types resolve union utils printer abbrev) (prefix-in t: (types abbrev numeric-tower subtype)) (private parse-type syntax-properties) racket/match racket/syntax racket/list @@ -83,8 +83,8 @@ (define (generate-contract-def stx cache sc-cache) (define prop (get-contract-def-property stx)) (match-define (contract-def type-stx flat? maker? typed-side) prop) - (define *typ (parse-type type-stx)) - (define kind (if flat? 'flat 'impersonator)) + (define *typ (if type-stx (parse-type type-stx) -Dead-Code)) + (define kind (if (and type-stx flat?) 'flat 'impersonator)) (syntax-parse stx #:literals (define-values) [(define-values (n) _) (define typ diff --git a/typed-racket-lib/typed-racket/typecheck/tc-if.rkt b/typed-racket-lib/typed-racket/typecheck/tc-if.rkt index bffd06d8..c5a211bd 100644 --- a/typed-racket-lib/typed-racket/typecheck/tc-if.rkt +++ b/typed-racket-lib/typed-racket/typecheck/tc-if.rkt @@ -1,13 +1,10 @@ #lang racket/unit -(require "../utils/utils.rkt" +(require "../utils/utils.rkt" racket/match (rep core-rep prop-rep) - (types abbrev utils prop-ops) + (types utils prop-ops) (utils tc-utils) (typecheck signatures tc-envops tc-metafunctions) - (types type-table) - (private syntax-properties) - racket/match - syntax/parse) + (types type-table)) ;; if typechecking (import tc-expr^) @@ -19,44 +16,13 @@ (define expected* (and expected (erase-props expected))) (define results-t (with-lexical-env/extend-props (list ps+) - #:unreachable (begin - (handle-unreachable-casted-exprs thn) - (warn-unreachable thn)) + #:unreachable (warn-unreachable thn) (test-position-add-true tst) (tc-expr/check thn expected*))) (define results-u (with-lexical-env/extend-props (list ps-) - #:unreachable (begin - (handle-unreachable-casted-exprs els) - (warn-unreachable els)) + #:unreachable (warn-unreachable els) (test-position-add-false tst) (tc-expr/check els expected*))) (merge-tc-results (list results-t results-u))])) - -;; handle-unreachable-casted-exprs : Any -> Void -;; Traverses stx looking for casted-expr properties. For each one, it -;; calls the function stored in the property, which fills an entry in -;; the cast table with the -Dead-Code type. This is so that the -;; contract-generation pass doesn't throw an internal error. -(define (handle-unreachable-casted-exprs stx) - (syntax-parse stx - [(exp:casted-expr^ e) - ;; fill in this entry in the cast table with the -Dead-Code type - ((attribute exp.value) -Dead-Code) - (void)] - [stx - (define e (syntax-e #'stx)) - (cond - [(pair? e) (handle-unreachable-casted-exprs (car e)) - (handle-unreachable-casted-exprs (cdr e))] - [(box? e) (handle-unreachable-casted-exprs (unbox e))] - [(vector? e) (for ([e (in-vector e)]) - (handle-unreachable-casted-exprs e))] - [(hash? e) (for ([(k v) (in-hash e)]) - (handle-unreachable-casted-exprs k) - (handle-unreachable-casted-exprs v))] - [(struct? e) (for ([e (in-vector (struct->vector e))]) - (handle-unreachable-casted-exprs e))] - [else (void)])])) - diff --git a/typed-racket-test/succeed/cast-mod.rkt b/typed-racket-test/succeed/cast-mod.rkt index b626b16b..c94a6498 100644 --- a/typed-racket-test/succeed/cast-mod.rkt +++ b/typed-racket-test/succeed/cast-mod.rkt @@ -117,5 +117,9 @@ 1) (check-equal? (if #true 1 `#s(struct ,(cast 2 Integer) ,(cast 3 Integer))) 1) + (check-true ;; check that this doesn't have an internal error + (λ () (begin + (error "hi") + (cast (string->number "42") Integer)))) )