From e4948f79c2a1b64cfe5992ef52172c5c387ad6d2 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Sat, 25 May 2013 16:16:24 -0700 Subject: [PATCH] Centralized typechecker:ignore properties. original commit: a325e380466fb5380782e2e2570024af29584d36 --- collects/typed-racket/base-env/prims.rkt | 35 +++++++++---------- collects/typed-racket/optimizer/optimizer.rkt | 5 +-- .../private/syntax-properties.rkt | 28 ++++++++++----- .../typed-racket/typecheck/tc-expr-unit.rkt | 6 ++-- .../typed-racket/typecheck/tc-toplevel.rkt | 12 +++---- 5 files changed, 48 insertions(+), 38 deletions(-) diff --git a/collects/typed-racket/base-env/prims.rkt b/collects/typed-racket/base-env/prims.rkt index f1f6ff8c..c1457738 100644 --- a/collects/typed-racket/base-env/prims.rkt +++ b/collects/typed-racket/base-env/prims.rkt @@ -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 ...) diff --git a/collects/typed-racket/optimizer/optimizer.rkt b/collects/typed-racket/optimizer/optimizer.rkt index 970b23fa..f443257e 100644 --- a/collects/typed-racket/optimizer/optimizer.rkt +++ b/collects/typed-racket/optimizer/optimizer.rkt @@ -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))) diff --git a/collects/typed-racket/private/syntax-properties.rkt b/collects/typed-racket/private/syntax-properties.rkt index 5f2f21eb..6c19afb5 100644 --- a/collects/typed-racket/private/syntax-properties.rkt +++ b/collects/typed-racket/private/syntax-properties.rkt @@ -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)))) diff --git a/collects/typed-racket/typecheck/tc-expr-unit.rkt b/collects/typed-racket/typecheck/tc-expr-unit.rkt index f042852c..f6cfdff4 100644 --- a/collects/typed-racket/typecheck/tc-expr-unit.rkt +++ b/collects/typed-racket/typecheck/tc-expr-unit.rkt @@ -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 diff --git a/collects/typed-racket/typecheck/tc-toplevel.rkt b/collects/typed-racket/typecheck/tc-toplevel.rkt index 49d9bab7..7651fba4 100644 --- a/collects/typed-racket/typecheck/tc-toplevel.rkt +++ b/collects/typed-racket/typecheck/tc-toplevel.rkt @@ -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))