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

Centralized typechecker:ignore properties.

Browse Source 
original commit: a325e380466fb5380782e2e2570024af29584d36
This commit is contained in:
Eric Dobson 2013-05-25 16:16:24 -07:00
parent 087eb91881
commit e4948f79c2
5 changed files with 48 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
collects/typed-racket/base-env/prims.rkt
View File

@ -74,7 +74,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
[typed-racket/private/type-contract (type->contract)]
[typed-racket/env/type-name-env (register-type-name)]))
(define-for-syntax (ignore stx) (syntax-property stx 'typechecker:ignore #t))
(define-for-syntax (ignore stx) (ignore-property stx #t))
(define-syntaxes (require/typed-legacy require/typed)
(let ()
@ -193,11 +193,11 @@ This file defines two sorts of primitives. All of them are provided into any mod
(syntax-parse stx
[(_ name:id ty:expr)
#`(begin
#,(syntax-property (if (eq? (syntax-local-context) 'top-level)
#,(ignore-property (if (eq? (syntax-local-context) 'top-level)
#'(define name (procedure-rename (make-predicate ty) 'name))
(syntax-property #'(define name #f)
'typechecker:flat-contract-def #'ty))
'typechecker:ignore #t)
#t)
;; not a require, this is just the unchecked declaration syntax
#,(internal #'(require/typed-internal name (Any -> Boolean : ty))))]))
@ -218,7 +218,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
#`(ann
#,(syntax-property
(syntax-property name 'typechecker:ignore-some #t)
(ignore-some-property name #t)
'typechecker:external-check check-valid-type)
(Any -> Boolean : ty)))
@ -227,7 +227,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
;; This code should never get run, typechecking will have an error earlier
#`(error 'make-predicate "Couldn't parse type")
#`(ann
#,(syntax-property
#,(ignore-some-property
(type->contract
typ
;; must be a flat contract
@ -235,7 +235,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
;; the value is not from the typed side
#:typed-side #f
(lambda () (tc-error/stx #'ty "Type ~a could not be converted to a predicate." typ)))
'typechecker:ignore-some #t)
#t)
(Any -> Boolean : ty)))))]))
(define-syntax (cast stx)
@ -244,7 +244,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
(define (apply-contract ctc-expr)
#`(#%expression
(ann
#,(syntax-property
#,(ignore-some-property
#`(let-values (((val) #,(syntax-property #'(ann v Any) 'with-type #t)))
(contract
#,ctc-expr
@ -253,7 +253,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
'typed-world
val
(quote-syntax #,stx)))
'typechecker:ignore-some #t)
#t)
ty)))
(cond [(not (unbox typed-context?)) ; no-check, don't check
@ -303,14 +303,12 @@ This file defines two sorts of primitives. All of them are provided into any mod
(with-syntax ([hidden (generate-temporary #'pred)])
(quasisyntax/loc stx
(begin
#,(syntax-property #'(define pred-cnt (any/c . c-> . boolean?))
'typechecker:ignore #t)
#,(ignore-property #'(define pred-cnt (any/c . c-> . boolean?)) #t)
#,(internal #'(require/typed-internal hidden (Any -> Boolean : (Opaque pred))))
#,(if (attribute ne)
(internal (syntax/loc stx (define-type-alias-internal ty (Opaque pred))))
(syntax/loc stx (define-type-alias ty (Opaque pred))))
#,(syntax-property #'(require/contract pred hidden pred-cnt lib)
'typechecker:ignore #t))))]))
#,(ignore-property #'(require/contract pred hidden pred-cnt lib) #t))))]))
(define-syntax (plambda: stx)
(syntax-parse stx
@ -496,9 +494,9 @@ This file defines two sorts of primitives. All of them are provided into any mod
[(_ nm ((~describe "field specification" [fld:optionally-annotated-name]) ...) [proc : proc-ty])
(with-syntax*
([proc* (syntax-property #'(ann proc : proc-ty) 'typechecker:with-type #t)]
[d-s (syntax-property (syntax/loc stx (define-struct nm (fld.name ...)
[d-s (ignore-some-property (syntax/loc stx (define-struct nm (fld.name ...)
#:property prop:procedure proc*))
'typechecker:ignore-some #t)]
#t)]
[dtsi (quasisyntax/loc stx (dtsi/exec* () nm (fld ...) proc-ty))])
#'(begin d-s dtsi))]))
@ -568,8 +566,9 @@ This file defines two sorts of primitives. All of them are provided into any mod
[(_ vars:maybe-type-vars nm:struct-name (fs:fld-spec ...)
opts:struct-options)
(let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())])
(with-syntax ([d-s (syntax-property (syntax/loc stx (define-struct nm (fs.fld ...) . opts))
'typechecker:ignore #t)]
(with-syntax ([d-s (ignore-some-property
(syntax/loc stx (define-struct nm (fs.fld ...) . opts))
#t)]
[dtsi (quasisyntax/loc stx
(dtsi* (vars.vars ...) nm (fs ...)
#,@mutable?))])
@ -580,11 +579,11 @@ This file defines two sorts of primitives. All of them are provided into any mod
opts:struct-options)
(let ([mutable? (if (attribute opts.mutable?) #'(#:mutable) #'())]
[cname (datum->syntax #f (format-symbol "make-~a" (syntax-e #'nm.name)))])
(with-syntax ([d-s (syntax-property (quasisyntax/loc stx
(with-syntax ([d-s (ignore-property (quasisyntax/loc stx
(struct #,@(attribute nm.new-spec) (fs.fld ...)
#:extra-constructor-name #,cname
. opts))
'typechecker:ignore #t)]
#t)]
[dtsi (quasisyntax/loc stx
(dtsi* (vars.vars ...)
nm.old-spec (fs ...)

5
collects/typed-racket/optimizer/optimizer.rkt
View File

@ -4,6 +4,7 @@
racket/pretty
(for-template racket/base)
"../utils/utils.rkt"
(private syntax-properties)
(optimizer utils logging
number fixnum float float-complex vector string list pair
sequence box struct dead-code apply unboxed-let
@ -96,8 +97,8 @@
([optimize
(syntax-parser
[e:expr
#:when (and (not (syntax-property #'e 'typechecker:ignore))
(not (syntax-property #'e 'typechecker:ignore-some))
#:when (and (not (ignore-property #'e))
(not (ignore-some-property #'e))
(not (syntax-property #'e 'typechecker:with-handlers))
#;
(not (syntax-property #'e 'kw-lambda)))

28
collects/typed-racket/private/syntax-properties.rkt
View File

@ -1,11 +1,23 @@
#lang racket/base
(require (for-syntax racket/base syntax/parse))
(provide plambda-property)
(define-syntax define-properties
(syntax-parser
((_ (name:id sym:id) ...)
(with-syntax (((symbol ...) (generate-temporaries #'(sym ...))))
#`(begin
(begin
;; TODO: make this an uninterned symbol once the phasing issue of the unit
;; tests is fixed
(define symbol 'sym)
(provide name)
(define name
(case-lambda
((stx) (syntax-property stx symbol))
((stx value) (syntax-property stx symbol value))))) ...)))))
(define-properties
(plambda-property typechecker:plambda)
(ignore-property typechecker:ignore)
(ignore-some-property typechecker:ignore-some))
;; TODO: make this an uninterned symbol once the phasing issue of the unit
;; tests is fixed
(define plambda-symbol 'typechecker:plambda)
(define plambda-property
(case-lambda
((stx) (syntax-property stx plambda-symbol))
((stx value) (syntax-property stx plambda-symbol value))))

6
collects/typed-racket/typecheck/tc-expr-unit.rkt
View File

@ -7,7 +7,7 @@
"check-below.rkt" "tc-funapp.rkt" "tc-app-helper.rkt" "../types/kw-types.rkt"
(types utils abbrev numeric-tower union subtype
type-table filter-ops generalize)
(private-in parse-type type-annotation)
(private-in parse-type type-annotation syntax-properties)
(rep type-rep filter-rep object-rep)
(only-in (infer infer) restrict)
(utils tc-utils stxclass-util)
@ -185,7 +185,7 @@
#:when (syntax-property form 'typechecker:with-handlers)
(check-subforms/with-handlers/check form expected)]
[stx
#:when (syntax-property form 'typechecker:ignore-some)
#:when (ignore-some-property form)
(check-subforms/ignore form)
;; We trust ignore to be only on syntax objects objects that are well typed
expected]
@ -311,7 +311,7 @@
(int-err "internal error: with-handlers"))
ty)]
[stx
#:when (syntax-property form 'typechecker:ignore-some)
#:when (ignore-some-property form)
(check-subforms/ignore form)
(ret Univ)]
;; explicit failure

12
collects/typed-racket/typecheck/tc-toplevel.rkt
View File

@ -6,7 +6,7 @@
(prefix-in c: (contract-req))
(rep type-rep free-variance)
(types utils abbrev type-table)
(private parse-type type-annotation type-contract)
(private parse-type type-annotation type-contract syntax-properties)
(env global-env init-envs type-name-env type-alias-env
lexical-env env-req mvar-env scoped-tvar-env)
(utils tc-utils mutated-vars)
@ -98,8 +98,7 @@
;; forms that are handled in other ways
[stx
#:when (or (syntax-property form 'typechecker:ignore)
(syntax-property form 'typechecker:ignore-some))
#:when (or (ignore-property form) (ignore-some-property form))
(list)]
[((~literal module) n:id spec ((~literal #%plain-module-begin) body ...))
@ -202,12 +201,12 @@
require/typed-internal values module module*)
;; these forms we have been instructed to ignore
[stx
(syntax-property form 'typechecker:ignore)
(ignore-property form)
(void)]
;; this is a form that we mostly ignore, but we check some interior parts
[stx
(syntax-property form 'typechecker:ignore-some)
(ignore-some-property form)
(check-subforms/ignore form)]
;; these forms should always be ignored
@ -417,8 +416,7 @@
(syntax-parse form
[((~literal begin) e ...)
;; Don't open up `begin`s that are supposed to be ignored
#:when (not (or (syntax-property form 'typechecker:ignore)
(syntax-property form 'typechecker:ignore-some)))
#:when (not (or (ignore-property form) (ignore-some-property form)))
(define result
(for/last ([form (syntax->list #'(e ...))])
(define-values (_ result) (tc-toplevel-form form))