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

Specialize ignore-some in expression position.

Browse Source 
We now do not return -Bottom from ignore-some, because it has
issues with improved handling of filters in check-below.
This commit is contained in:
Eric Dobson 2014-05-26 11:20:32 -07:00
parent 9e3b984463
commit 0c5c6f50c1
5 changed files with 35 additions and 40 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt
View File

@ -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) (define-for-syntax (with-type* expr ty)
(with-type #`(ann #,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 (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 ~a could not be converted to a predicate because it contains free variables."
type))) type)))
#`(ann #`(#,(external-check-property #'#%expression check-valid-type)
(#,(external-check-property #'#%expression check-valid-type) #,(ignore-some/expr name #'(Any -> Boolean : ty))))
#,(ignore-some name))
(Any -> Boolean : ty)))
(let ([typ (parse-type #'ty)]) (let ([typ (parse-type #'ty)])
(if (Error? typ) (if (Error? typ)
;; This code should never get run, typechecking will have an error earlier ;; This code should never get run, typechecking will have an error earlier
#`(error 'make-predicate "Couldn't parse type") #`(error 'make-predicate "Couldn't parse type")
#`(#%expression #`(#%expression
(ann #,(ignore-some/expr
#,(ignore-some (type->contract
(type->contract typ
typ ;; must be a flat contract
;; must be a flat contract #:kind 'flat
#:kind 'flat ;; the value is not from the typed side
;; the value is not from the typed side #:typed-side #f
#:typed-side #f (type->contract-fail typ #'ty #:ctc-str "predicate"))
(type->contract-fail typ #'ty #:ctc-str "predicate"))) #'(Any -> Boolean : ty))))))]))
(Any -> Boolean : ty))))))]))
(define-syntax (cast stx) (define-syntax (cast stx)
(syntax-parse stx (syntax-parse stx
[(_ v:expr ty:expr) [(_ v:expr ty:expr)
(define (apply-contract ctc-expr) (define (apply-contract ctc-expr)
#`(#%expression #`(#%expression
(ann #,(ignore-some/expr
#,(ignore-some #`(let-values (((val) #,(with-type* #'v #'Any)))
#`(let-values (((val) #,(with-type* #'v #'Any))) #,(syntax-property
#,(syntax-property (quasisyntax/loc stx
(quasisyntax/loc stx (contract
(contract #,ctc-expr
#,ctc-expr val
val 'cast
'cast 'typed-world
'typed-world val
val (quote-syntax #,stx)))
(quote-syntax #,stx))) 'feature-profile:TR-dynamic-check #t))
'feature-profile:TR-dynamic-check #t))) #'ty)))
ty)))
(cond [(not (unbox typed-context?)) ; no-check, don't check (cond [(not (unbox typed-context?)) ; no-check, don't check
#'v] #'v]

1
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/syntax-properties.rkt
View File

@ -49,6 +49,7 @@
(plambda typechecker:plambda) (plambda typechecker:plambda)
(ignore typechecker:ignore #:mark) (ignore typechecker:ignore #:mark)
(ignore-some typechecker:ignore-some #:mark) (ignore-some typechecker:ignore-some #:mark)
(ignore-some-expr typechecker:ignore-some)
(contract-def/maker typechecker:contract-def/maker) (contract-def/maker typechecker:contract-def/maker)
(contract-def typechecker:contract-def) (contract-def typechecker:contract-def)
(flat-contract-def typechecker:flat-contract-def) (flat-contract-def typechecker:flat-contract-def)

1
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-below.rkt
View File

@ -15,6 +15,7 @@
[cond-check-below (-->i ([s (-or/c Type/c full-tc-results/c)] [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))]) [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))])] [_ (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?)) [type-mismatch (-->* ((-or/c Type/c string?) (-or/c Type/c string?))
((-or/c string? #f)) ((-or/c string? #f))
-any)]) -any)])

9
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt
View File

@ -100,11 +100,6 @@
[stx:exn-handlers^ [stx:exn-handlers^
(register-ignored! form) (register-ignored! form)
(check-subforms/with-handlers/check form expected)] (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 ;; explicit failure
[t:typecheck-failure [t:typecheck-failure
(explicit-fail #'t.stx #'t.message #'t.var)] (explicit-fail #'t.stx #'t.message #'t.var)]
@ -237,10 +232,6 @@
[stx:exn-handlers^ [stx:exn-handlers^
(register-ignored! form) (register-ignored! form)
(check-subforms/with-handlers form) ] (check-subforms/with-handlers form) ]
[stx:ignore-some^
(register-ignored! form)
(check-subforms/ignore form)
(ret Univ)]
;; explicit failure ;; explicit failure
[t:typecheck-failure [t:typecheck-failure
(explicit-fail #'t.stx #'t.message #'t.var)] (explicit-fail #'t.stx #'t.message #'t.var)]

10
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expression.rkt
View File

@ -2,8 +2,8 @@
(require (require
"../utils/utils.rkt" "../utils/utils.rkt"
(typecheck tc-expr-unit signatures tc-app-helper) (typecheck tc-expr-unit signatures tc-app-helper check-below)
(types tc-result tc-error utils abbrev classes) (types tc-result tc-error utils abbrev classes type-table)
(rep type-rep) (rep type-rep)
(utils tc-utils) (utils tc-utils)
(env index-env tvar-env scoped-tvar-env) (env index-env tvar-env scoped-tvar-env)
@ -15,7 +15,7 @@
syntax/parse) syntax/parse)
(import tc-expr^) (import tc-expr^ check-subforms^)
(export tc-expression^) (export tc-expression^)
;; Typecheck an (#%expression e) form ;; Typecheck an (#%expression e) form
@ -26,6 +26,10 @@
[(exp:type-ascription^ e) [(exp:type-ascription^ e)
(add-scoped-tvars #'e (parse-literal-alls (attribute exp.value))) (add-scoped-tvars #'e (parse-literal-alls (attribute exp.value)))
(tc-expr/check #'e (parse-tc-results (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) [(exp:external-check^ e)
((attribute exp.value) #'e) ((attribute exp.value) #'e)
(if expected (if expected