From fca7a3b26f90bb6bee8772869089d816be8d66c8 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Mon, 26 May 2014 11:20:32 -0700 Subject: [PATCH] Specialize ignore-some in expression position. We now do not return -Bottom from ignore-some, because it has issues with improved handling of filters in check-below. original commit: 0c5c6f50c1a794d79cdea8b76133727aa93e0422 --- .../typed-racket/base-env/prims.rkt | 54 +++++++++---------- .../private/syntax-properties.rkt | 1 + .../typed-racket/typecheck/check-below.rkt | 1 + .../typed-racket/typecheck/tc-expr-unit.rkt | 9 ---- .../typed-racket/typecheck/tc-expression.rkt | 10 ++-- 5 files changed, 35 insertions(+), 40 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt index e49446fb..95ca66b1 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt @@ -143,6 +143,8 @@ This file defines two sorts of primitives. All of them are provided into any mod (define-for-syntax (with-type* expr ty) (with-type #`(ann #,expr #,ty))) +(define-for-syntax (ignore-some/expr expr ty) + #`(#,(ignore-some-expr-property #'#%expression ty) #,expr)) (begin-for-syntax @@ -308,45 +310,41 @@ This file defines two sorts of primitives. All of them are provided into any mod "Type ~a could not be converted to a predicate because it contains free variables." type))) - #`(ann - (#,(external-check-property #'#%expression check-valid-type) - #,(ignore-some name)) - (Any -> Boolean : ty))) + #`(#,(external-check-property #'#%expression check-valid-type) + #,(ignore-some/expr name #'(Any -> Boolean : ty)))) (let ([typ (parse-type #'ty)]) (if (Error? typ) ;; This code should never get run, typechecking will have an error earlier #`(error 'make-predicate "Couldn't parse type") #`(#%expression - (ann - #,(ignore-some - (type->contract - typ - ;; must be a flat contract - #:kind 'flat - ;; the value is not from the typed side - #:typed-side #f - (type->contract-fail typ #'ty #:ctc-str "predicate"))) - (Any -> Boolean : ty))))))])) + #,(ignore-some/expr + (type->contract + typ + ;; must be a flat contract + #:kind 'flat + ;; the value is not from the typed side + #:typed-side #f + (type->contract-fail typ #'ty #:ctc-str "predicate")) + #'(Any -> Boolean : ty))))))])) (define-syntax (cast stx) (syntax-parse stx [(_ v:expr ty:expr) (define (apply-contract ctc-expr) #`(#%expression - (ann - #,(ignore-some - #`(let-values (((val) #,(with-type* #'v #'Any))) - #,(syntax-property - (quasisyntax/loc stx - (contract - #,ctc-expr - val - 'cast - 'typed-world - val - (quote-syntax #,stx))) - 'feature-profile:TR-dynamic-check #t))) - ty))) + #,(ignore-some/expr + #`(let-values (((val) #,(with-type* #'v #'Any))) + #,(syntax-property + (quasisyntax/loc stx + (contract + #,ctc-expr + val + 'cast + 'typed-world + val + (quote-syntax #,stx))) + 'feature-profile:TR-dynamic-check #t)) + #'ty))) (cond [(not (unbox typed-context?)) ; no-check, don't check #'v] diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/syntax-properties.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/syntax-properties.rkt index 097b7c73..53bf1b62 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/syntax-properties.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/syntax-properties.rkt @@ -49,6 +49,7 @@ (plambda typechecker:plambda) (ignore typechecker:ignore #:mark) (ignore-some typechecker:ignore-some #:mark) + (ignore-some-expr typechecker:ignore-some) (contract-def/maker typechecker:contract-def/maker) (contract-def typechecker:contract-def) (flat-contract-def typechecker:flat-contract-def) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-below.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-below.rkt index dcf6f40f..f4c865d2 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-below.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-below.rkt @@ -15,6 +15,7 @@ [cond-check-below (-->i ([s (-or/c Type/c full-tc-results/c)] [t (s) (-or/c #f (if (Type/c? s) Type/c tc-results/c))]) [_ (s) (-or/c #f (if (Type/c? s) Type/c full-tc-results/c))])] + [fix-results (--> tc-results/c full-tc-results/c)] [type-mismatch (-->* ((-or/c Type/c string?) (-or/c Type/c string?)) ((-or/c string? #f)) -any)]) 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 828d2b17..97f642f4 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 @@ -100,11 +100,6 @@ [stx:exn-handlers^ (register-ignored! form) (check-subforms/with-handlers/check form expected)] - [stx:ignore-some^ - (register-ignored! form) - (check-subforms/ignore form) - ;; We trust ignore to be only on syntax objects objects that are well typed - (ret -Bottom)] ;; explicit failure [t:typecheck-failure (explicit-fail #'t.stx #'t.message #'t.var)] @@ -237,10 +232,6 @@ [stx:exn-handlers^ (register-ignored! form) (check-subforms/with-handlers form) ] - [stx:ignore-some^ - (register-ignored! form) - (check-subforms/ignore form) - (ret Univ)] ;; explicit failure [t:typecheck-failure (explicit-fail #'t.stx #'t.message #'t.var)] diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expression.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expression.rkt index 30275404..e6b530c4 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expression.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expression.rkt @@ -2,8 +2,8 @@ (require "../utils/utils.rkt" - (typecheck tc-expr-unit signatures tc-app-helper) - (types tc-result tc-error utils abbrev classes) + (typecheck tc-expr-unit signatures tc-app-helper check-below) + (types tc-result tc-error utils abbrev classes type-table) (rep type-rep) (utils tc-utils) (env index-env tvar-env scoped-tvar-env) @@ -15,7 +15,7 @@ syntax/parse) -(import tc-expr^) +(import tc-expr^ check-subforms^) (export tc-expression^) ;; Typecheck an (#%expression e) form @@ -26,6 +26,10 @@ [(exp:type-ascription^ e) (add-scoped-tvars #'e (parse-literal-alls (attribute exp.value))) (tc-expr/check #'e (parse-tc-results (attribute exp.value)))] + [(exp:ignore-some-expr^ e) + (register-ignored! #'e) + (check-subforms/ignore #'e) + (fix-results (parse-tc-results (attribute exp.value)))] [(exp:external-check^ e) ((attribute exp.value) #'e) (if expected