diff --git a/collects/typed-racket/base-env/annotate-classes.rkt b/collects/typed-racket/base-env/annotate-classes.rkt index af4a0c5dc9..f258755f7e 100644 --- a/collects/typed-racket/base-env/annotate-classes.rkt +++ b/collects/typed-racket/base-env/annotate-classes.rkt @@ -1,6 +1,8 @@ #lang racket/base -(require syntax/parse "../private/parse-classes.rkt" +(require syntax/parse + "../private/parse-classes.rkt" + "../private/syntax-properties.rkt" (for-template "colon.rkt")) (provide (all-defined-out)) @@ -9,10 +11,10 @@ #:description "type-annotated identifier" #:literals (:) (pattern [~seq name:id : ty] - #:with ann-name (syntax-property #'name 'type-label #'ty)) + #:with ann-name (type-label-property #'name #'ty)) (pattern name:id - #:when (syntax-property #'name 'type-label) - #:with ty (syntax-property #'name 'type-label) + #:with ty (type-label-property #'name) + #:when #'ty #:with ann-name #'name)) (define-splicing-syntax-class optionally-annotated-name @@ -31,7 +33,7 @@ #:description "type-annotated identifier" #:literals (:) (pattern [~seq name:id : ty] - #:with ann-name (syntax-property #'name 'type-label (trans #'ty)))) + #:with ann-name (type-label-property #'name (trans #'ty)))) (define-syntax-class annotated-binding #:attributes (name ty ann-name binding rhs) @@ -74,7 +76,7 @@ #:literals (:) (pattern (~seq name:id : ty s:star) #:with formal-ty #'(ty s) - #:with ann-name (syntax-property #'name 'type-label #'ty))) + #:with ann-name (type-label-property #'name #'ty))) (define-splicing-syntax-class annotated-dots-rest #:attributes (name ann-name bound ty formal-ty) @@ -82,8 +84,9 @@ (pattern (~seq name:id : ty bnd:ddd/bound) #:with formal-ty #'(ty . bnd) #:attr bound (attribute bnd.bound) - #:with ann-name (syntax-property (syntax-property #'name 'type-label #'ty) - 'type-dotted (attribute bnd.bound)))) + #:with ann-name (type-dotted-property + (type-label-property #'name #'ty) + (attribute bnd.bound)))) (define-syntax-class annotated-formal #:description "annotated variable of the form [x : T]" diff --git a/collects/typed-racket/base-env/prims.rkt b/collects/typed-racket/base-env/prims.rkt index c1457738da..407a50c8dc 100644 --- a/collects/typed-racket/base-env/prims.rkt +++ b/collects/typed-racket/base-env/prims.rkt @@ -155,9 +155,10 @@ This file defines two sorts of primitives. All of them are provided into any mod (define/with-syntax sm (if (attribute parent) #'(#:struct-maker parent) #'())) - (define prop-name (if (attribute parent) - 'typechecker:contract-def/maker - 'typechecker:contract-def)) + (define property + (if (attribute parent) + contract-def/maker-property + contract-def-property)) (quasisyntax/loc stx (begin ;; define `cnt*` to be fixed up later by the module @@ -165,7 +166,7 @@ This file defines two sorts of primitives. All of them are provided into any mod ;; doesn't work with local expansion) #,@(ignore (if (eq? (syntax-local-context) 'top-level) #'() - #`(#,(syntax-property #'(define cnt* #f) prop-name #'ty)))) + #`(#,(property #'(define cnt* #f) #'ty)))) #,(internal #'(require/typed-internal hidden ty . sm)) #,(ignore #'(require/contract nm.spec hidden cnt* lib))))])) (values (r/t-maker #t) (r/t-maker #f)))) @@ -195,8 +196,7 @@ This file defines two sorts of primitives. All of them are provided into any mod #`(begin #,(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)) + (flat-contract-def-property #'(define name #f) #'ty)) #t) ;; not a require, this is just the unchecked declaration syntax #,(internal #'(require/typed-internal name (Any -> Boolean : ty))))])) @@ -206,7 +206,7 @@ This file defines two sorts of primitives. All of them are provided into any mod [(_ ty:expr) (if (syntax-transforming-module-expression?) (let ((name (syntax-local-lift-expression - (syntax-property #'#f 'typechecker:flat-contract-def #'ty)))) + (flat-contract-def-property #'#f #'ty)))) (define (check-valid-type _) (define type (parse-type #'ty)) (define vars (fv type)) @@ -217,10 +217,7 @@ This file defines two sorts of primitives. All of them are provided into any mod type))) #`(ann - #,(syntax-property - (ignore-some-property name #t) - 'typechecker:external-check check-valid-type) - + #,(external-check-property (ignore-some-property name #t) check-valid-type) (Any -> Boolean : ty))) (let ([typ (parse-type #'ty)]) (if (Error? typ) @@ -245,7 +242,7 @@ This file defines two sorts of primitives. All of them are provided into any mod #`(#%expression (ann #,(ignore-some-property - #`(let-values (((val) #,(syntax-property #'(ann v Any) 'with-type #t))) + #`(let-values (((val) #,(with-type-property #'(ann v Any) #t))) (contract #,ctc-expr val @@ -260,7 +257,7 @@ This file defines two sorts of primitives. All of them are provided into any mod #'v] [(syntax-transforming-module-expression?) (let ((ctc (syntax-local-lift-expression - (syntax-property #'#f 'typechecker:contract-def #'ty)))) + (contract-def-property #'#f #'ty)))) (define (check-valid-type _) (define type (parse-type #'ty)) (define vars (fv type)) @@ -269,8 +266,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (tc-error/delayed "Type ~a could not be converted to a contract because it contains free variables." type))) - (syntax-property (apply-contract ctc) - 'typechecker:external-check check-valid-type))] + (external-check-property (apply-contract ctc) check-valid-type))] [else (let ([typ (parse-type #'ty)]) (if (Error? typ) @@ -352,7 +348,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (define-syntax (ann stx) (syntax-parse stx #:literals (:) [(_ (~or (~seq arg : ty) (~seq arg ty))) - (syntax-property #'arg 'type-ascription #'ty)])) + (type-ascription-property #'arg #'ty)])) (define-syntax (inst stx) (syntax-parse stx #:literals (:) @@ -360,9 +356,9 @@ This file defines two sorts of primitives. All of them are provided into any mod (syntax/loc stx (inst arg . tys))] [(_ arg tys ... ty ddd b:id) #:when (eq? (syntax-e #'ddd) '...) - (syntax-property #'arg 'type-inst #'(tys ... (ty . b)))] + (type-inst-property #'arg #'(tys ... (ty . b)))] [(_ arg tys ...) - (syntax-property #'arg 'type-inst #'(tys ...))])) + (type-inst-property #'arg #'(tys ...))])) (define-syntax (define: stx) (syntax-parse stx #:literals (:) @@ -373,7 +369,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (lambda: formals body ...))))] [(define: nm:id ~! (~describe ":" :) (~describe "type" ty) body) (identifier? #'nm) - (with-syntax ([new-nm (syntax-property #'nm 'type-label #'ty)]) + (with-syntax ([new-nm (type-label-property #'nm #'ty)]) (syntax/loc stx (define new-nm body)))] [(define: (tvars:id ...) nm:id : ty body) (with-syntax ([type (syntax/loc #'ty (All (tvars ...) ty))]) @@ -470,14 +466,12 @@ This file defines two sorts of primitives. All of them are provided into any mod (define-syntax (with-handlers: stx) (syntax-parse stx [(_ ([pred? action] ...) . body) - (with-syntax ([(pred?* ...) (map (lambda (s) (syntax-property #`(ann #,s : (Any -> Any)) 'typechecker:with-type #t)) + (with-syntax ([(pred?* ...) (map (lambda (s) (with-type-property #`(ann #,s : (Any -> Any)) #t)) (syntax->list #'(pred? ...)))] [(action* ...) - (map (lambda (s) (syntax-property s 'typechecker:exn-handler #t)) (syntax->list #'(action ...)))] - [body* (syntax-property #'(let-values () . body) 'typechecker:exn-body #t)]) - (syntax-property #'(with-handlers ([pred?* action*] ...) body*) - 'typechecker:with-handlers - #t))])) + (map (lambda (s) (exn-handler-property s #t)) (syntax->list #'(action ...)))] + [body* (exn-body-property #'(let-values () . body) #t)]) + (with-handlers-property #'(with-handlers ([pred?* action*] ...) body*) #t))])) (begin-for-syntax (define-syntax-class dtsi-struct-name @@ -493,7 +487,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (syntax-parse stx #:literals (:) [(_ nm ((~describe "field specification" [fld:optionally-annotated-name]) ...) [proc : proc-ty]) (with-syntax* - ([proc* (syntax-property #'(ann proc : proc-ty) 'typechecker:with-type #t)] + ([proc* (with-type-property #'(ann proc : proc-ty) #t)] [d-s (ignore-some-property (syntax/loc stx (define-struct nm (fld.name ...) #:property prop:procedure proc*)) #t)] @@ -508,11 +502,11 @@ This file defines two sorts of primitives. All of them are provided into any mod [(_ () nm:dtsi-struct-name . rest) (internal (quasisyntax/loc stx (#,internal-id - #,(syntax-property #'nm 'struct-info (attribute nm.value)) . rest)))] + #,(struct-info-property #'nm (attribute nm.value)) . rest)))] [(_ (vars:id ...) nm:dtsi-struct-name . rest) (internal (quasisyntax/loc stx (#,internal-id (vars ...) - #,(syntax-property #'nm 'struct-info (attribute nm.value)) . rest)))]))) + #,(struct-info-property #'nm (attribute nm.value)) . rest)))]))) (values (mk #'define-typed-struct-internal) (mk #'define-typed-struct/exec-internal)))) @@ -755,7 +749,7 @@ This file defines two sorts of primitives. All of them are provided into any mod ;; c is not always an expression, could be a break-clause clauses c ...) ; no need to annotate the type, it's always Void (let ((body #`(; break-clause ... - #,@(syntax-property #'(c ...) 'type-ascription #'Void)))) + #,@(type-ascription-property #'(c ...) #'Void)))) (let loop ((clauses #'clauses)) (define-splicing-syntax-class for-clause ;; single-valued seq-expr @@ -778,20 +772,18 @@ This file defines two sorts of primitives. All of them are provided into any mod #:with replace-with #'unless)) (syntax-parse clauses [(head:for-clause next:for-clause ... kw:for-kw rest ...) - (syntax-property + (type-ascription-property (quasisyntax/loc stx (for (head.expand ... next.expand ... ...) #,(loop #'(kw rest ...)))) - 'type-ascription #'Void)] [(head:for-clause ...) ; we reached the end - (syntax-property + (type-ascription-property (quasisyntax/loc stx (for (head.expand ... ...) #,@body)) - 'type-ascription #'Void)] [(kw:for-kw guard) ; we end on a keyword clause (quasisyntax/loc stx @@ -804,7 +796,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (define-for-syntax (maybe-annotate-body body ty) (if (syntax-e ty) - (syntax-property body 'type-ascription ty) + (type-ascription-property body ty) body)) ;; Handling #:when clauses manually, like we do with for: above breaks @@ -851,22 +843,20 @@ This file defines two sorts of primitives. All of them are provided into any mod ((var:optionally-annotated-name) ...) clause:for-clauses c ...) ; c is not always an expression, can be a break-clause - (syntax-property + (type-ascription-property (quasisyntax/loc stx (for/lists (var.ann-name ...) (clause.expand ... ...) c ...)) - 'type-ascription #'ty)] [(_ ((var:annotated-name) ...) clause:for-clauses c ...) - (syntax-property + (type-ascription-property (quasisyntax/loc stx (for/lists (var.ann-name ...) (clause.expand ... ...) c ...)) - 'type-ascription #'(values var.ty ...))])) (define-syntax (for/fold: stx) (syntax-parse stx #:literals (:) @@ -874,22 +864,20 @@ This file defines two sorts of primitives. All of them are provided into any mod ((var:optionally-annotated-name init:expr) ...) clause:for-clauses c ...) ; c is not always an expression, can be a break-clause - (syntax-property + (type-ascription-property (quasisyntax/loc stx (for/fold ((var.ann-name init) ...) (clause.expand ... ...) c ...)) - 'type-ascription #'ty)] [(_ accum:accumulator-bindings clause:for-clauses c ...) - (syntax-property + (type-ascription-property (quasisyntax/loc stx (for/fold ((accum.ann-name accum.init) ...) (clause.expand ... ...) c ...)) - 'type-ascription #'(values accum.ty ...))])) @@ -934,22 +922,20 @@ This file defines two sorts of primitives. All of them are provided into any mod ((var:optionally-annotated-name) ...) clause:for-clauses c ...) ; c is not always an expression, can be a break-clause - (syntax-property + (type-ascription-property (quasisyntax/loc stx (for/lists (var.ann-name ...) (clause.expand* ... ...) c ...)) - 'type-ascription #'ty)] [(_ ((var:annotated-name) ...) clause:for-clauses c ...) - (syntax-property + (type-ascription-property (quasisyntax/loc stx (for/lists (var.ann-name ...) (clause.expand* ... ...) c ...)) - 'type-ascription #'(values var.ty ...))])) (define-syntax (for*/fold: stx) (syntax-parse stx #:literals (:) @@ -957,22 +943,20 @@ This file defines two sorts of primitives. All of them are provided into any mod ((var:optionally-annotated-name init:expr) ...) clause:for-clauses c ...) ; c is not always an expression, can be a break-clause - (syntax-property + (type-ascription-property (quasisyntax/loc stx (for/fold ((var.ann-name init) ...) (clause.expand* ... ...) c ...)) - 'type-ascription #'ty)] [(_ ((var:annotated-name init:expr) ...) clause:for-clauses c ...) - (syntax-property + (type-ascription-property (quasisyntax/loc stx (for/fold ((var.ann-name init) ...) (clause.expand* ... ...) c ...)) - 'type-ascription #'(values var.ty ...))])) (define-for-syntax (define-for/acc:-variant for*? for/folder: for/folder op initial final) @@ -1088,9 +1072,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (values (ormap keyword? (map syntax-e arg-list)) (ormap syntax->list arg-list))))) - (syntax-property - (syntax-property d 'kw-lambda has-kw?) - 'opt-lambda has-opt?)])) + (opt-lambda-property (kw-lambda-property d has-kw?) has-opt?)])) ;; do this ourselves so that we don't get the static bindings, ;; which are harder to typecheck diff --git a/collects/typed-racket/core.rkt b/collects/typed-racket/core.rkt index c5b8d131ca..6360bf22cd 100644 --- a/collects/typed-racket/core.rkt +++ b/collects/typed-racket/core.rkt @@ -3,7 +3,7 @@ (require (rename-in "utils/utils.rkt") (for-syntax racket/base) (for-template racket/base) - (private with-types type-contract parse-type) + (private with-types type-contract parse-type syntax-properties) (except-in syntax/parse id) racket/match racket/syntax unstable/match racket/list syntax/stx racket/format @@ -88,8 +88,7 @@ (with-syntax ([(dummy-arg ...) (generate-temporaries #'(arg-type ...))]) (tc-setup #'stx ;; create a dummy function with the right argument types - #`(lambda #,(stx-map (lambda (a t) - (syntax-property a 'type-label t)) + #`(lambda #,(stx-map type-label-property #'(dummy-arg ...) #'(arg-type ...)) (op dummy-arg ...)) 'top-level expanded init tc-toplevel-form before type diff --git a/collects/typed-racket/optimizer/optimizer.rkt b/collects/typed-racket/optimizer/optimizer.rkt index cd5c64544f..d05fe69522 100644 --- a/collects/typed-racket/optimizer/optimizer.rkt +++ b/collects/typed-racket/optimizer/optimizer.rkt @@ -26,7 +26,7 @@ ;; can't optimize the body of this code because it isn't typechecked (pattern ((~and op (~literal let-values)) ([(i:id) e-rhs:expr]) e-body:expr ...) - #:when (syntax-property this-syntax 'kw-lambda) + #:when (kw-lambda-property this-syntax) #:with opt-rhs ((optimize) #'e-rhs) #:with opt (quasisyntax/loc/origin this-syntax #'op (op ([(i) opt-rhs]) e-body ...))) @@ -99,9 +99,9 @@ [e:expr #:when (and (not (ignore-property #'e)) (not (ignore-some-property #'e)) - (not (syntax-property #'e 'typechecker:with-handlers)) + (not (with-handlers-property #'e)) #; - (not (syntax-property #'e 'kw-lambda))) + (not (kw-lambda-property #'e))) #:with e*:opt-expr #'e #'e*.opt] [e:expr #'e])]) diff --git a/collects/typed-racket/private/syntax-properties.rkt b/collects/typed-racket/private/syntax-properties.rkt index 6c19afb549..4cc1441d19 100644 --- a/collects/typed-racket/private/syntax-properties.rkt +++ b/collects/typed-racket/private/syntax-properties.rkt @@ -16,8 +16,28 @@ ((stx) (syntax-property stx symbol)) ((stx value) (syntax-property stx symbol value))))) ...))))) +;;TODO add contracts on the properties +;;TODO make better interface for properties with values of only #t + (define-properties (plambda-property typechecker:plambda) (ignore-property typechecker:ignore) - (ignore-some-property typechecker:ignore-some)) + (ignore-some-property typechecker:ignore-some) + (contract-def/maker-property typechecker:contract-def/maker) + (contract-def-property typechecker:contract-def) + (flat-contract-def-property typechecker:flat-contract-def) + (external-check-property typechecker:external-check) + (with-type-property typechecker:with-type) + (type-ascription-property type-ascription) + (type-inst-property type-inst) + (type-label-property type-label) + (type-dotted-property type-dotted) + (exn-handler-property typechecker:exn-handler) + (exn-body-property typechecker:exn-body) + (with-handlers-property typechecker:with-handlers) + (struct-info-property struct-info) + (opt-lambda-property opt-lambda) + (kw-lambda-property kw-lambda) + (tail-position-property typechecker:called-in-tail-position) + ) diff --git a/collects/typed-racket/private/type-annotation.rkt b/collects/typed-racket/private/type-annotation.rkt index 6d36b11ed4..076b626a89 100644 --- a/collects/typed-racket/private/type-annotation.rkt +++ b/collects/typed-racket/private/type-annotation.rkt @@ -5,7 +5,7 @@ (utils tc-utils) (env global-env mvar-env scoped-tvar-env) (except-in (types subtype union resolve utils generalize)) - (private parse-type) + (private parse-type syntax-properties) (contract-req) racket/match) @@ -13,17 +13,11 @@ get-type get-types get-type/infer - type-label-symbol - type-ascrip-symbol - type-dotted-symbol type-ascription remove-ascription check-type dotted?) -(define type-label-symbol 'type-label) -(define type-ascrip-symbol 'type-ascription) -(define type-dotted-symbol 'type-dotted) ;; get the type annotation of this syntax ;; syntax -> Maybe[Type] @@ -43,8 +37,8 @@ ;(unless let-binding (error 'ohno)) ;(printf "in type-annotation:~a\n" (syntax->datum stx)) (cond - [(syntax-property stx type-label-symbol) => pt] - [(syntax-property stx type-ascrip-symbol) => pt] + [(type-label-property stx) => pt] + [(type-ascription-property stx) => pt] ;; this is so that : annotation works in internal def ctxts [(and (identifier? stx) (lookup-type stx (lambda () #f))) => @@ -62,7 +56,7 @@ (parse-tc-results prop) (parse-tc-results/id stx prop))) (cond - [(syntax-property stx type-ascrip-symbol) + [(type-ascription-property stx) => (lambda (prop) (let loop ((prop prop)) @@ -72,18 +66,19 @@ [else #f])) (define (remove-ascription stx) - (syntax-property stx type-ascrip-symbol - (cond - [(syntax-property stx type-ascrip-symbol) - => - (lambda (prop) - (if (pair? prop) - (let loop ((prop (cdr prop)) (last (car prop))) - (if (pair? prop) - (cons last (loop (cdr prop) (car prop))) - last)) - #f))] - [else #f]))) + (type-ascription-property + stx + (cond + [(type-ascription-property stx) + => + (lambda (prop) + (if (pair? prop) + (let loop ((prop (cdr prop)) (last (car prop))) + (if (pair? prop) + (cons last (loop (cdr prop) (car prop))) + last)) + #f))] + [else #f]))) ;; get the type annotation of this identifier, otherwise error ;; if #:default is provided, return that instead of error @@ -148,5 +143,5 @@ (tc-error "Body had type:\n~a\nVariable had type:\n~a\n" e-type ty)))) (define (dotted? stx) - (cond [(syntax-property stx type-dotted-symbol) => syntax-e] + (cond [(type-dotted-property stx) => syntax-e] [else #f])) diff --git a/collects/typed-racket/private/type-contract.rkt b/collects/typed-racket/private/type-contract.rkt index bde0a76f0a..89ee3a6f35 100644 --- a/collects/typed-racket/private/type-contract.rkt +++ b/collects/typed-racket/private/type-contract.rkt @@ -13,7 +13,7 @@ (env type-name-env) (types resolve utils) (prefix-in t: (types abbrev numeric-tower)) - (private parse-type) + (private parse-type syntax-properties) racket/match unstable/match syntax/struct syntax/stx racket/syntax racket/list (contract-req) (for-template racket/base racket/contract racket/set (utils any-wrap) @@ -29,15 +29,15 @@ typechecker:contract-def/maker) (let () (define ((get-contract-def property) stx) - (or (syntax-property stx property) + (or (property stx) (syntax-case stx (define-values) ((define-values (name) body) - (syntax-property #'body property)) + (property #'body)) (_ #f)))) (values - (get-contract-def 'typechecker:contract-def) - (get-contract-def 'typechecker:flat-contract-def) - (get-contract-def 'typechecker:contract-def/maker)))) + (get-contract-def contract-def-property) + (get-contract-def flat-contract-def-property) + (get-contract-def contract-def/maker-property)))) (define (define/fixup-contract? stx) (or (typechecker:contract-def stx) diff --git a/collects/typed-racket/typecheck/check-subforms-unit.rkt b/collects/typed-racket/typecheck/check-subforms-unit.rkt index 5b9221eaab..eb855f42ad 100644 --- a/collects/typed-racket/typecheck/check-subforms-unit.rkt +++ b/collects/typed-racket/typecheck/check-subforms-unit.rkt @@ -7,6 +7,7 @@ "signatures.rkt" "tc-metafunctions.rkt" "tc-funapp.rkt" "tc-subst.rkt" (types utils abbrev union subtype resolve) + (private syntax-properties) (utils tc-utils) (rep type-rep)) @@ -56,19 +57,19 @@ (syntax-parse form [stx ;; if this needs to be checked - #:when (syntax-property form 'typechecker:with-type) + #:when (with-type-property form) ;; the form should be already ascribed the relevant type (tc-expr form)] [stx ;; this is a handler function - #:when (syntax-property form 'typechecker:exn-handler) + #:when (exn-handler-property form) (let ([t (single-value form)]) (match t [(tc-result1: t) (set! handler-tys (cons (get-result-ty t) handler-tys))]))] [stx ;; this is the body of the with-handlers - #:when (syntax-property form 'typechecker:exn-body) + #:when (exn-body-property form) (set! body-stx form) (set! body-ty (tc-expr form))] [(a . b) @@ -84,16 +85,16 @@ (kernel-syntax-case* form #f () [stx ;; if this needs to be checked - (syntax-property form 'typechecker:with-type) + (with-type-property form) ;; the form should be already ascribed the relevant type (tc-expr form)] [stx ;; this is a hander function - (syntax-property form 'typechecker:exn-handler) + (exn-handler-property form) (tc-expr/check form (ret (-> (Un) (tc-results->values expected))))] [stx ;; this is the body of the with-handlers - (syntax-property form 'typechecker:exn-body) + (exn-body-property form) (tc-expr/check form expected)] [(a . b) (begin @@ -109,7 +110,7 @@ (kernel-syntax-case* form #f () [stx ;; if this needs to be checked - (syntax-property form 'typechecker:with-type) + (with-type-property form) ;; the form should be already ascribed the relevant type (void (tc-expr form))] [(a . b) diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-main.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-main.rkt index f1cf7aceb0..e1591d0cd3 100644 --- a/collects/typed-racket/typecheck/tc-app/tc-app-main.rkt +++ b/collects/typed-racket/typecheck/tc-app/tc-app-main.rkt @@ -7,6 +7,7 @@ syntax/parse/experimental/reflect (typecheck signatures tc-funapp tc-app-helper tc-subst) (types utils abbrev) + (private syntax-properties) (rep type-rep filter-rep object-rep rep-utils) (for-template racket/base)) @@ -18,8 +19,8 @@ (define-syntax-class annotated-op (pattern i:identifier - #:when (or (syntax-property #'i 'type-inst) - (syntax-property #'i 'type-ascription)))) + #:when (or (type-inst-property #'i) + (type-ascription-property #'i)))) (define-tc/app-syntax-class (tc/app-annotated expected) ;; Just do regular typechecking if we have one of these. diff --git a/collects/typed-racket/typecheck/tc-expr-unit.rkt b/collects/typed-racket/typecheck/tc-expr-unit.rkt index 8734b57d56..1c88029d66 100644 --- a/collects/typed-racket/typecheck/tc-expr-unit.rkt +++ b/collects/typed-racket/typecheck/tc-expr-unit.rkt @@ -25,7 +25,7 @@ ;; do-inst : syntax type -> type (define (do-inst stx ty) - (define inst (syntax-property stx 'type-inst)) + (define inst (type-inst-property stx)) (define (split-last l) (let-values ([(all-but last-list) (split-at l (sub1 (length l)))]) (values all-but (car last-list)))) @@ -125,10 +125,10 @@ ;; around again in case there is an instantiation ;; remove the ascription so we don't loop infinitely (loop (remove-ascription form*) r* #t)))] - [(syntax-property form* 'type-inst) + [(type-inst-property form*) ;; check without property first ;; to get the appropriate type to instantiate - (match (tc-expr (syntax-property form* 'type-inst #f)) + (match (tc-expr (type-inst-property form* #f)) [(tc-results: ts fs os) ;; do the instantiation on the old type (let* ([ts* (do-inst form* ts)] @@ -138,11 +138,11 @@ (check-below ts** expected))] ;; no annotations possible on dotted results [ty (add-typeof-expr form ty) ty])] - [(syntax-property form* 'typechecker:external-check) + [(external-check-property form*) => (lambda (check) (check form*) - (loop (syntax-property form* 'typechecker:external-check #f) + (loop (external-check-property form* #f) expected checked?))] ;; nothing to see here @@ -182,7 +182,7 @@ #:literal-sets (kernel-literals) #:literals (find-method/who) [stx - #:when (syntax-property form 'typechecker:with-handlers) + #:when (with-handlers-property form) (check-subforms/with-handlers/check form expected)] [stx #:when (ignore-some-property form) @@ -266,8 +266,7 @@ ;; kw/opt function def [(let-values ([(_) fun]) . body) - #:when (or (syntax-property form 'kw-lambda) - (syntax-property form 'opt-lambda)) + #:when (or (kw-lambda-property form) (opt-lambda-property form)) (match expected [(tc-result1: (and f (or (Function: _) (Poly: _ (Function: _))))) @@ -305,7 +304,7 @@ #:literals (#%app lambda find-method/who) ;; [stx - #:when (syntax-property form 'typechecker:with-handlers) + #:when (with-handlers-property form) (let ([ty (check-subforms/with-handlers form)]) (unless ty (int-err "internal error: with-handlers")) diff --git a/collects/typed-racket/typecheck/tc-let-unit.rkt b/collects/typed-racket/typecheck/tc-let-unit.rkt index 1c54bf203d..9fa7146b57 100644 --- a/collects/typed-racket/typecheck/tc-let-unit.rkt +++ b/collects/typed-racket/typecheck/tc-let-unit.rkt @@ -4,7 +4,7 @@ (only-in srfi/1/list s:member) (except-in (types utils abbrev union) -> ->* one-of/c) (only-in (types abbrev) (-> t:->)) - (private type-annotation parse-type) + (private type-annotation parse-type syntax-properties) (env lexical-env type-alias-env global-env type-env-structs scoped-tvar-env) (rep type-rep filter-rep object-rep) syntax/free-vars @@ -216,10 +216,10 @@ (define ((tc-expr-t/maybe-expected expected) e) (syntax-parse e #:literals (#%plain-lambda) [(#%plain-lambda () _) - #:fail-unless (and expected (syntax-property e 'typechecker:called-in-tail-position)) #f + #:fail-unless (and expected (tail-position-property e)) #f (tc-expr/check e (ret (t:-> (tc-results->values expected))))] [_ - #:fail-unless (and expected (syntax-property e 'typechecker:called-in-tail-position)) #f + #:fail-unless (and expected (tail-position-property e)) #f (tc-expr/check e expected)] [_ (tc-expr e)])) diff --git a/collects/typed-racket/typecheck/tc-structs.rkt b/collects/typed-racket/typecheck/tc-structs.rkt index d71ed24f23..054c7ab3c5 100644 --- a/collects/typed-racket/typecheck/tc-structs.rkt +++ b/collects/typed-racket/typecheck/tc-structs.rkt @@ -6,7 +6,7 @@ (prefix-in c: (contract-req)) (rep type-rep object-rep free-variance) - (private parse-type) + (private parse-type syntax-properties) (types abbrev utils union resolve substitute type-table) (env global-env type-env-structs type-name-env tvar-env) (utils tc-utils) @@ -280,7 +280,7 @@ (and proc-ty (parse-type proc-ty)))) (define sty (mk/inner-struct-type names desc concrete-parent)) - (parsed-struct sty names desc (syntax-property nm/par 'struct-info) type-only)) + (parsed-struct sty names desc (struct-info-property nm/par) type-only)) ;; register a struct type diff --git a/collects/typed-racket/typecheck/tc-toplevel.rkt b/collects/typed-racket/typecheck/tc-toplevel.rkt index bb4e500d21..6563961cfc 100644 --- a/collects/typed-racket/typecheck/tc-toplevel.rkt +++ b/collects/typed-racket/typecheck/tc-toplevel.rkt @@ -159,7 +159,7 @@ (let* ([vars (syntax->list #'(var ...))]) (cond ;; if all the variables have types, we stick them into the environment - [(andmap (lambda (s) (syntax-property s 'type-label)) vars) + [(andmap type-label-property vars) (let ([ts (map (λ (x) (get-type x #:infer #f)) vars)]) (for-each register-type-if-undefined vars ts) (map make-def-binding vars ts))] diff --git a/collects/typed-racket/typed-reader.rkt b/collects/typed-racket/typed-reader.rkt index 6721ff81fa..a72c31bbc7 100644 --- a/collects/typed-racket/typed-reader.rkt +++ b/collects/typed-racket/typed-reader.rkt @@ -2,6 +2,8 @@ ;; Provides raise-read-error and raise-read-eof-error (require syntax/readerr) +(require "private/syntax-properties.rkt") + (define (skip-whitespace port) ;; Skips whitespace characters, sensitive to the current @@ -37,7 +39,7 @@ (case (syntax-e next) ;; type annotation [(:) (skip-whitespace port) - (syntax-property name 'type-label (syntax->datum (read-one)))] + (type-label-property name (syntax->datum (read-one)))] [(::) (skip-whitespace port) (datum->syntax name `(ann ,name : ,(read-one)))] [(@) (let ([elems (let loop ([es '()])