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

Consolidate the rest of the syntax properties in TR.

Browse Source 
(cherry picked from commit 4310f04eaf)
This commit is contained in:
Eric Dobson 2013-05-25 17:22:34 -07:00 committed by Ryan Culpepper
parent 7383a685e3
commit 8b1c643bca
14 changed files with 124 additions and 122 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
collects/typed-racket/base-env/annotate-classes.rkt
View File

@ -1,6 +1,8 @@
#lang racket/base #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")) (for-template "colon.rkt"))
(provide (all-defined-out)) (provide (all-defined-out))
@ -9,10 +11,10 @@
#:description "type-annotated identifier" #:description "type-annotated identifier"
#:literals (:) #:literals (:)
(pattern [~seq name:id : ty] (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 (pattern name:id
#:when (syntax-property #'name 'type-label) #:with ty (type-label-property #'name)
#:with ty (syntax-property #'name 'type-label) #:when #'ty
#:with ann-name #'name)) #:with ann-name #'name))
(define-splicing-syntax-class optionally-annotated-name (define-splicing-syntax-class optionally-annotated-name
@ -31,7 +33,7 @@
#:description "type-annotated identifier" #:description "type-annotated identifier"
#:literals (:) #:literals (:)
(pattern [~seq name:id : ty] (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 (define-syntax-class annotated-binding
#:attributes (name ty ann-name binding rhs) #:attributes (name ty ann-name binding rhs)
@ -74,7 +76,7 @@
#:literals (:) #:literals (:)
(pattern (~seq name:id : ty s:star) (pattern (~seq name:id : ty s:star)
#:with formal-ty #'(ty s) #: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 (define-splicing-syntax-class annotated-dots-rest
#:attributes (name ann-name bound ty formal-ty) #:attributes (name ann-name bound ty formal-ty)
@ -82,8 +84,9 @@
(pattern (~seq name:id : ty bnd:ddd/bound) (pattern (~seq name:id : ty bnd:ddd/bound)
#:with formal-ty #'(ty . bnd) #:with formal-ty #'(ty . bnd)
#:attr bound (attribute bnd.bound) #:attr bound (attribute bnd.bound)
#:with ann-name (syntax-property (syntax-property #'name 'type-label #'ty) #:with ann-name (type-dotted-property
'type-dotted (attribute bnd.bound)))) (type-label-property #'name #'ty)
(attribute bnd.bound))))
(define-syntax-class annotated-formal (define-syntax-class annotated-formal
#:description "annotated variable of the form [x : T]" #:description "annotated variable of the form [x : T]"

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

@ -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) (define/with-syntax sm (if (attribute parent)
#'(#:struct-maker parent) #'(#:struct-maker parent)
#'())) #'()))
(define prop-name (if (attribute parent) (define property
'typechecker:contract-def/maker (if (attribute parent)
'typechecker:contract-def)) contract-def/maker-property
contract-def-property))
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin
;; define `cnt*` to be fixed up later by the module ;; 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) ;; doesn't work with local expansion)
#,@(ignore (if (eq? (syntax-local-context) 'top-level) #,@(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)) #,(internal #'(require/typed-internal hidden ty . sm))
#,(ignore #'(require/contract nm.spec hidden cnt* lib))))])) #,(ignore #'(require/contract nm.spec hidden cnt* lib))))]))
(values (r/t-maker #t) (r/t-maker #f)))) (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 #`(begin
#,(ignore-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)) #'(define name (procedure-rename (make-predicate ty) 'name))
(syntax-property #'(define name #f) (flat-contract-def-property #'(define name #f) #'ty))
'typechecker:flat-contract-def #'ty))
#t) #t)
;; not a require, this is just the unchecked declaration syntax ;; not a require, this is just the unchecked declaration syntax
#,(internal #'(require/typed-internal name (Any -> Boolean : ty))))])) #,(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) [(_ ty:expr)
(if (syntax-transforming-module-expression?) (if (syntax-transforming-module-expression?)
(let ((name (syntax-local-lift-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 (check-valid-type _)
(define type (parse-type #'ty)) (define type (parse-type #'ty))
(define vars (fv type)) (define vars (fv type))
@ -217,10 +217,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
type))) type)))
#`(ann #`(ann
#,(syntax-property #,(external-check-property (ignore-some-property name #t) check-valid-type)
(ignore-some-property name #t)
'typechecker:external-check check-valid-type)
(Any -> Boolean : ty))) (Any -> Boolean : ty)))
(let ([typ (parse-type #'ty)]) (let ([typ (parse-type #'ty)])
(if (Error? typ) (if (Error? typ)
@ -245,7 +242,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
#`(#%expression #`(#%expression
(ann (ann
#,(ignore-some-property #,(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 (contract
#,ctc-expr #,ctc-expr
val val
@ -260,7 +257,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
#'v] #'v]
[(syntax-transforming-module-expression?) [(syntax-transforming-module-expression?)
(let ((ctc (syntax-local-lift-expression (let ((ctc (syntax-local-lift-expression
(syntax-property #'#f 'typechecker:contract-def #'ty)))) (contract-def-property #'#f #'ty))))
(define (check-valid-type _) (define (check-valid-type _)
(define type (parse-type #'ty)) (define type (parse-type #'ty))
(define vars (fv type)) (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 (tc-error/delayed
"Type ~a could not be converted to a contract because it contains free variables." "Type ~a could not be converted to a contract because it contains free variables."
type))) type)))
(syntax-property (apply-contract ctc) (external-check-property (apply-contract ctc) check-valid-type))]
'typechecker:external-check check-valid-type))]
[else [else
(let ([typ (parse-type #'ty)]) (let ([typ (parse-type #'ty)])
(if (Error? typ) (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) (define-syntax (ann stx)
(syntax-parse stx #:literals (:) (syntax-parse stx #:literals (:)
[(_ (~or (~seq arg : ty) (~seq arg ty))) [(_ (~or (~seq arg : ty) (~seq arg ty)))
(syntax-property #'arg 'type-ascription #'ty)])) (type-ascription-property #'arg #'ty)]))
(define-syntax (inst stx) (define-syntax (inst stx)
(syntax-parse stx #:literals (:) (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))] (syntax/loc stx (inst arg . tys))]
[(_ arg tys ... ty ddd b:id) [(_ arg tys ... ty ddd b:id)
#:when (eq? (syntax-e #'ddd) '...) #:when (eq? (syntax-e #'ddd) '...)
(syntax-property #'arg 'type-inst #'(tys ... (ty . b)))] (type-inst-property #'arg #'(tys ... (ty . b)))]
[(_ arg tys ...) [(_ arg tys ...)
(syntax-property #'arg 'type-inst #'(tys ...))])) (type-inst-property #'arg #'(tys ...))]))
(define-syntax (define: stx) (define-syntax (define: stx)
(syntax-parse stx #:literals (:) (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 ...))))] (lambda: formals body ...))))]
[(define: nm:id ~! (~describe ":" :) (~describe "type" ty) body) [(define: nm:id ~! (~describe ":" :) (~describe "type" ty) body)
(identifier? #'nm) (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)))] (syntax/loc stx (define new-nm body)))]
[(define: (tvars:id ...) nm:id : ty body) [(define: (tvars:id ...) nm:id : ty body)
(with-syntax ([type (syntax/loc #'ty (All (tvars ...) ty))]) (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) (define-syntax (with-handlers: stx)
(syntax-parse stx (syntax-parse stx
[(_ ([pred? action] ...) . body) [(_ ([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? ...)))] (syntax->list #'(pred? ...)))]
[(action* ...) [(action* ...)
(map (lambda (s) (syntax-property s 'typechecker:exn-handler #t)) (syntax->list #'(action ...)))] (map (lambda (s) (exn-handler-property s #t)) (syntax->list #'(action ...)))]
[body* (syntax-property #'(let-values () . body) 'typechecker:exn-body #t)]) [body* (exn-body-property #'(let-values () . body) #t)])
(syntax-property #'(with-handlers ([pred?* action*] ...) body*) (with-handlers-property #'(with-handlers ([pred?* action*] ...) body*) #t))]))
'typechecker:with-handlers
#t))]))
(begin-for-syntax (begin-for-syntax
(define-syntax-class dtsi-struct-name (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 (:) (syntax-parse stx #:literals (:)
[(_ nm ((~describe "field specification" [fld:optionally-annotated-name]) ...) [proc : proc-ty]) [(_ nm ((~describe "field specification" [fld:optionally-annotated-name]) ...) [proc : proc-ty])
(with-syntax* (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 ...) [d-s (ignore-some-property (syntax/loc stx (define-struct nm (fld.name ...)
#:property prop:procedure proc*)) #:property prop:procedure proc*))
#t)] #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) [(_ () nm:dtsi-struct-name . rest)
(internal (quasisyntax/loc stx (internal (quasisyntax/loc stx
(#,internal-id (#,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) [(_ (vars:id ...) nm:dtsi-struct-name . rest)
(internal (quasisyntax/loc stx (internal (quasisyntax/loc stx
(#,internal-id (vars ...) (#,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) (values (mk #'define-typed-struct-internal)
(mk #'define-typed-struct/exec-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 ;; c is not always an expression, could be a break-clause
clauses c ...) ; no need to annotate the type, it's always Void clauses c ...) ; no need to annotate the type, it's always Void
(let ((body #`(; break-clause ... (let ((body #`(; break-clause ...
#,@(syntax-property #'(c ...) 'type-ascription #'Void)))) #,@(type-ascription-property #'(c ...) #'Void))))
(let loop ((clauses #'clauses)) (let loop ((clauses #'clauses))
(define-splicing-syntax-class for-clause (define-splicing-syntax-class for-clause
;; single-valued seq-expr ;; 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)) #:with replace-with #'unless))
(syntax-parse clauses (syntax-parse clauses
[(head:for-clause next:for-clause ... kw:for-kw rest ...) [(head:for-clause next:for-clause ... kw:for-kw rest ...)
(syntax-property (type-ascription-property
(quasisyntax/loc stx (quasisyntax/loc stx
(for (for
(head.expand ... next.expand ... ...) (head.expand ... next.expand ... ...)
#,(loop #'(kw rest ...)))) #,(loop #'(kw rest ...))))
'type-ascription
#'Void)] #'Void)]
[(head:for-clause ...) ; we reached the end [(head:for-clause ...) ; we reached the end
(syntax-property (type-ascription-property
(quasisyntax/loc stx (quasisyntax/loc stx
(for (for
(head.expand ... ...) (head.expand ... ...)
#,@body)) #,@body))
'type-ascription
#'Void)] #'Void)]
[(kw:for-kw guard) ; we end on a keyword clause [(kw:for-kw guard) ; we end on a keyword clause
(quasisyntax/loc stx (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) (define-for-syntax (maybe-annotate-body body ty)
(if (syntax-e ty) (if (syntax-e ty)
(syntax-property body 'type-ascription ty) (type-ascription-property body ty)
body)) body))
;; Handling #:when clauses manually, like we do with for: above breaks ;; 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) ...) ((var:optionally-annotated-name) ...)
clause:for-clauses clause:for-clauses
c ...) ; c is not always an expression, can be a break-clause c ...) ; c is not always an expression, can be a break-clause
(syntax-property (type-ascription-property
(quasisyntax/loc stx (quasisyntax/loc stx
(for/lists (var.ann-name ...) (for/lists (var.ann-name ...)
(clause.expand ... ...) (clause.expand ... ...)
c ...)) c ...))
'type-ascription
#'ty)] #'ty)]
[(_ ((var:annotated-name) ...) [(_ ((var:annotated-name) ...)
clause:for-clauses clause:for-clauses
c ...) c ...)
(syntax-property (type-ascription-property
(quasisyntax/loc stx (quasisyntax/loc stx
(for/lists (var.ann-name ...) (for/lists (var.ann-name ...)
(clause.expand ... ...) (clause.expand ... ...)
c ...)) c ...))
'type-ascription
#'(values var.ty ...))])) #'(values var.ty ...))]))
(define-syntax (for/fold: stx) (define-syntax (for/fold: stx)
(syntax-parse stx #:literals (:) (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) ...) ((var:optionally-annotated-name init:expr) ...)
clause:for-clauses clause:for-clauses
c ...) ; c is not always an expression, can be a break-clause c ...) ; c is not always an expression, can be a break-clause
(syntax-property (type-ascription-property
(quasisyntax/loc stx (quasisyntax/loc stx
(for/fold ((var.ann-name init) ...) (for/fold ((var.ann-name init) ...)
(clause.expand ... ...) (clause.expand ... ...)
c ...)) c ...))
'type-ascription
#'ty)] #'ty)]
[(_ accum:accumulator-bindings [(_ accum:accumulator-bindings
clause:for-clauses clause:for-clauses
c ...) c ...)
(syntax-property (type-ascription-property
(quasisyntax/loc stx (quasisyntax/loc stx
(for/fold ((accum.ann-name accum.init) ...) (for/fold ((accum.ann-name accum.init) ...)
(clause.expand ... ...) (clause.expand ... ...)
c ...)) c ...))
'type-ascription
#'(values accum.ty ...))])) #'(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) ...) ((var:optionally-annotated-name) ...)
clause:for-clauses clause:for-clauses
c ...) ; c is not always an expression, can be a break-clause c ...) ; c is not always an expression, can be a break-clause
(syntax-property (type-ascription-property
(quasisyntax/loc stx (quasisyntax/loc stx
(for/lists (var.ann-name ...) (for/lists (var.ann-name ...)
(clause.expand* ... ...) (clause.expand* ... ...)
c ...)) c ...))
'type-ascription
#'ty)] #'ty)]
[(_ ((var:annotated-name) ...) [(_ ((var:annotated-name) ...)
clause:for-clauses clause:for-clauses
c ...) c ...)
(syntax-property (type-ascription-property
(quasisyntax/loc stx (quasisyntax/loc stx
(for/lists (var.ann-name ...) (for/lists (var.ann-name ...)
(clause.expand* ... ...) (clause.expand* ... ...)
c ...)) c ...))
'type-ascription
#'(values var.ty ...))])) #'(values var.ty ...))]))
(define-syntax (for*/fold: stx) (define-syntax (for*/fold: stx)
(syntax-parse stx #:literals (:) (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) ...) ((var:optionally-annotated-name init:expr) ...)
clause:for-clauses clause:for-clauses
c ...) ; c is not always an expression, can be a break-clause c ...) ; c is not always an expression, can be a break-clause
(syntax-property (type-ascription-property
(quasisyntax/loc stx (quasisyntax/loc stx
(for/fold ((var.ann-name init) ...) (for/fold ((var.ann-name init) ...)
(clause.expand* ... ...) (clause.expand* ... ...)
c ...)) c ...))
'type-ascription
#'ty)] #'ty)]
[(_ ((var:annotated-name init:expr) ...) [(_ ((var:annotated-name init:expr) ...)
clause:for-clauses clause:for-clauses
c ...) c ...)
(syntax-property (type-ascription-property
(quasisyntax/loc stx (quasisyntax/loc stx
(for/fold ((var.ann-name init) ...) (for/fold ((var.ann-name init) ...)
(clause.expand* ... ...) (clause.expand* ... ...)
c ...)) c ...))
'type-ascription
#'(values var.ty ...))])) #'(values var.ty ...))]))
(define-for-syntax (define-for/acc:-variant for*? for/folder: for/folder op initial final) (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 (values
(ormap keyword? (map syntax-e arg-list)) (ormap keyword? (map syntax-e arg-list))
(ormap syntax->list arg-list))))) (ormap syntax->list arg-list)))))
(syntax-property (opt-lambda-property (kw-lambda-property d has-kw?) has-opt?)]))
(syntax-property d 'kw-lambda has-kw?)
'opt-lambda has-opt?)]))
;; do this ourselves so that we don't get the static bindings, ;; do this ourselves so that we don't get the static bindings,
;; which are harder to typecheck ;; which are harder to typecheck

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

@ -3,7 +3,7 @@
(require (rename-in "utils/utils.rkt") (require (rename-in "utils/utils.rkt")
(for-syntax racket/base) (for-syntax racket/base)
(for-template 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) (except-in syntax/parse id)
racket/match racket/syntax unstable/match racket/list syntax/stx racket/match racket/syntax unstable/match racket/list syntax/stx
racket/format racket/format
@ -88,8 +88,7 @@
(with-syntax ([(dummy-arg ...) (generate-temporaries #'(arg-type ...))]) (with-syntax ([(dummy-arg ...) (generate-temporaries #'(arg-type ...))])
(tc-setup #'stx (tc-setup #'stx
;; create a dummy function with the right argument types ;; create a dummy function with the right argument types
#`(lambda #,(stx-map (lambda (a t) #`(lambda #,(stx-map type-label-property
(syntax-property a 'type-label t))
#'(dummy-arg ...) #'(arg-type ...)) #'(dummy-arg ...) #'(arg-type ...))
(op dummy-arg ...)) (op dummy-arg ...))
'top-level expanded init tc-toplevel-form before type 'top-level expanded init tc-toplevel-form before type

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

@ -26,7 +26,7 @@
;; can't optimize the body of this code because it isn't typechecked ;; can't optimize the body of this code because it isn't typechecked
(pattern ((~and op (~literal let-values)) (pattern ((~and op (~literal let-values))
([(i:id) e-rhs:expr]) e-body:expr ...) ([(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-rhs ((optimize) #'e-rhs)
#:with opt (quasisyntax/loc/origin this-syntax #'op #:with opt (quasisyntax/loc/origin this-syntax #'op
(op ([(i) opt-rhs]) e-body ...))) (op ([(i) opt-rhs]) e-body ...)))
@ -99,9 +99,9 @@
[e:expr [e:expr
#:when (and (not (ignore-property #'e)) #:when (and (not (ignore-property #'e))
(not (ignore-some-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 #:with e*:opt-expr #'e
#'e*.opt] #'e*.opt]
[e:expr #'e])]) [e:expr #'e])])

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

@ -16,8 +16,28 @@
((stx) (syntax-property stx symbol)) ((stx) (syntax-property stx symbol))
((stx value) (syntax-property stx symbol value))))) ...))))) ((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 (define-properties
(plambda-property typechecker:plambda) (plambda-property typechecker:plambda)
(ignore-property typechecker:ignore) (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)
)

41
collects/typed-racket/private/type-annotation.rkt
View File

@ -5,7 +5,7 @@
(utils tc-utils) (utils tc-utils)
(env global-env mvar-env scoped-tvar-env) (env global-env mvar-env scoped-tvar-env)
(except-in (types subtype union resolve utils generalize)) (except-in (types subtype union resolve utils generalize))
(private parse-type) (private parse-type syntax-properties)
(contract-req) (contract-req)
racket/match) racket/match)
@ -13,17 +13,11 @@
get-type get-type
get-types get-types
get-type/infer get-type/infer
type-label-symbol
type-ascrip-symbol
type-dotted-symbol
type-ascription type-ascription
remove-ascription remove-ascription
check-type check-type
dotted?) 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 ;; get the type annotation of this syntax
;; syntax -> Maybe[Type] ;; syntax -> Maybe[Type]
@ -43,8 +37,8 @@
;(unless let-binding (error 'ohno)) ;(unless let-binding (error 'ohno))
;(printf "in type-annotation:~a\n" (syntax->datum stx)) ;(printf "in type-annotation:~a\n" (syntax->datum stx))
(cond (cond
[(syntax-property stx type-label-symbol) => pt] [(type-label-property stx) => pt]
[(syntax-property stx type-ascrip-symbol) => pt] [(type-ascription-property stx) => pt]
;; this is so that : annotation works in internal def ctxts ;; this is so that : annotation works in internal def ctxts
[(and (identifier? stx) (lookup-type stx (lambda () #f))) [(and (identifier? stx) (lookup-type stx (lambda () #f)))
=> =>
@ -62,7 +56,7 @@
(parse-tc-results prop) (parse-tc-results prop)
(parse-tc-results/id stx prop))) (parse-tc-results/id stx prop)))
(cond (cond
[(syntax-property stx type-ascrip-symbol) [(type-ascription-property stx)
=> =>
(lambda (prop) (lambda (prop)
(let loop ((prop prop)) (let loop ((prop prop))
@ -72,18 +66,19 @@
[else #f])) [else #f]))
(define (remove-ascription stx) (define (remove-ascription stx)
(syntax-property stx type-ascrip-symbol (type-ascription-property
(cond stx
[(syntax-property stx type-ascrip-symbol) (cond
=> [(type-ascription-property stx)
(lambda (prop) =>
(if (pair? prop) (lambda (prop)
(let loop ((prop (cdr prop)) (last (car prop))) (if (pair? prop)
(if (pair? prop) (let loop ((prop (cdr prop)) (last (car prop)))
(cons last (loop (cdr prop) (car prop))) (if (pair? prop)
last)) (cons last (loop (cdr prop) (car prop)))
#f))] last))
[else #f]))) #f))]
[else #f])))
;; get the type annotation of this identifier, otherwise error ;; get the type annotation of this identifier, otherwise error
;; if #:default is provided, return that instead of 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)))) (tc-error "Body had type:\n~a\nVariable had type:\n~a\n" e-type ty))))
(define (dotted? stx) (define (dotted? stx)
(cond [(syntax-property stx type-dotted-symbol) => syntax-e] (cond [(type-dotted-property stx) => syntax-e]
[else #f])) [else #f]))

12
collects/typed-racket/private/type-contract.rkt
View File

@ -13,7 +13,7 @@
(env type-name-env) (env type-name-env)
(types resolve utils) (types resolve utils)
(prefix-in t: (types abbrev numeric-tower)) (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 racket/match unstable/match syntax/struct syntax/stx racket/syntax racket/list
(contract-req) (contract-req)
(for-template racket/base racket/contract racket/set (utils any-wrap) (for-template racket/base racket/contract racket/set (utils any-wrap)
@ -29,15 +29,15 @@
typechecker:contract-def/maker) typechecker:contract-def/maker)
(let () (let ()
(define ((get-contract-def property) stx) (define ((get-contract-def property) stx)
(or (syntax-property stx property) (or (property stx)
(syntax-case stx (define-values) (syntax-case stx (define-values)
((define-values (name) body) ((define-values (name) body)
(syntax-property #'body property)) (property #'body))
(_ #f)))) (_ #f))))
(values (values
(get-contract-def 'typechecker:contract-def) (get-contract-def contract-def-property)
(get-contract-def 'typechecker:flat-contract-def) (get-contract-def flat-contract-def-property)
(get-contract-def 'typechecker:contract-def/maker)))) (get-contract-def contract-def/maker-property))))
(define (define/fixup-contract? stx) (define (define/fixup-contract? stx)
(or (typechecker:contract-def stx) (or (typechecker:contract-def stx)

15
collects/typed-racket/typecheck/check-subforms-unit.rkt
View File

@ -7,6 +7,7 @@
"signatures.rkt" "tc-metafunctions.rkt" "signatures.rkt" "tc-metafunctions.rkt"
"tc-funapp.rkt" "tc-subst.rkt" "tc-funapp.rkt" "tc-subst.rkt"
(types utils abbrev union subtype resolve) (types utils abbrev union subtype resolve)
(private syntax-properties)
(utils tc-utils) (utils tc-utils)
(rep type-rep)) (rep type-rep))
@ -56,19 +57,19 @@
(syntax-parse form (syntax-parse form
[stx [stx
;; if this needs to be checked ;; 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 ;; the form should be already ascribed the relevant type
(tc-expr form)] (tc-expr form)]
[stx [stx
;; this is a handler function ;; this is a handler function
#:when (syntax-property form 'typechecker:exn-handler) #:when (exn-handler-property form)
(let ([t (single-value form)]) (let ([t (single-value form)])
(match t (match t
[(tc-result1: t) [(tc-result1: t)
(set! handler-tys (cons (get-result-ty t) handler-tys))]))] (set! handler-tys (cons (get-result-ty t) handler-tys))]))]
[stx [stx
;; this is the body of the with-handlers ;; 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-stx form)
(set! body-ty (tc-expr form))] (set! body-ty (tc-expr form))]
[(a . b) [(a . b)
@ -84,16 +85,16 @@
(kernel-syntax-case* form #f () (kernel-syntax-case* form #f ()
[stx [stx
;; if this needs to be checked ;; 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 ;; the form should be already ascribed the relevant type
(tc-expr form)] (tc-expr form)]
[stx [stx
;; this is a hander function ;; 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))))] (tc-expr/check form (ret (-> (Un) (tc-results->values expected))))]
[stx [stx
;; this is the body of the with-handlers ;; this is the body of the with-handlers
(syntax-property form 'typechecker:exn-body) (exn-body-property form)
(tc-expr/check form expected)] (tc-expr/check form expected)]
[(a . b) [(a . b)
(begin (begin
@ -109,7 +110,7 @@
(kernel-syntax-case* form #f () (kernel-syntax-case* form #f ()
[stx [stx
;; if this needs to be checked ;; 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 ;; the form should be already ascribed the relevant type
(void (tc-expr form))] (void (tc-expr form))]
[(a . b) [(a . b)

5
collects/typed-racket/typecheck/tc-app/tc-app-main.rkt
View File

@ -7,6 +7,7 @@
syntax/parse/experimental/reflect syntax/parse/experimental/reflect
(typecheck signatures tc-funapp tc-app-helper tc-subst) (typecheck signatures tc-funapp tc-app-helper tc-subst)
(types utils abbrev) (types utils abbrev)
(private syntax-properties)
(rep type-rep filter-rep object-rep rep-utils) (rep type-rep filter-rep object-rep rep-utils)
(for-template racket/base)) (for-template racket/base))
@ -18,8 +19,8 @@
(define-syntax-class annotated-op (define-syntax-class annotated-op
(pattern i:identifier (pattern i:identifier
#:when (or (syntax-property #'i 'type-inst) #:when (or (type-inst-property #'i)
(syntax-property #'i 'type-ascription)))) (type-ascription-property #'i))))
(define-tc/app-syntax-class (tc/app-annotated expected) (define-tc/app-syntax-class (tc/app-annotated expected)
;; Just do regular typechecking if we have one of these. ;; Just do regular typechecking if we have one of these.

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

@ -25,7 +25,7 @@
;; do-inst : syntax type -> type ;; do-inst : syntax type -> type
(define (do-inst stx ty) (define (do-inst stx ty)
(define inst (syntax-property stx 'type-inst)) (define inst (type-inst-property stx))
(define (split-last l) (define (split-last l)
(let-values ([(all-but last-list) (split-at l (sub1 (length l)))]) (let-values ([(all-but last-list) (split-at l (sub1 (length l)))])
(values all-but (car last-list)))) (values all-but (car last-list))))
@ -125,10 +125,10 @@
;; around again in case there is an instantiation ;; around again in case there is an instantiation
;; remove the ascription so we don't loop infinitely ;; remove the ascription so we don't loop infinitely
(loop (remove-ascription form*) r* #t)))] (loop (remove-ascription form*) r* #t)))]
[(syntax-property form* 'type-inst) [(type-inst-property form*)
;; check without property first ;; check without property first
;; to get the appropriate type to instantiate ;; 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) [(tc-results: ts fs os)
;; do the instantiation on the old type ;; do the instantiation on the old type
(let* ([ts* (do-inst form* ts)] (let* ([ts* (do-inst form* ts)]
@ -138,11 +138,11 @@
(check-below ts** expected))] (check-below ts** expected))]
;; no annotations possible on dotted results ;; no annotations possible on dotted results
[ty (add-typeof-expr form ty) ty])] [ty (add-typeof-expr form ty) ty])]
[(syntax-property form* 'typechecker:external-check) [(external-check-property form*)
=> =>
(lambda (check) (lambda (check)
(check form*) (check form*)
(loop (syntax-property form* 'typechecker:external-check #f) (loop (external-check-property form* #f)
expected expected
checked?))] checked?))]
;; nothing to see here ;; nothing to see here
@ -182,7 +182,7 @@
#:literal-sets (kernel-literals) #:literal-sets (kernel-literals)
#:literals (find-method/who) #:literals (find-method/who)
[stx [stx
#:when (syntax-property form 'typechecker:with-handlers) #:when (with-handlers-property form)
(check-subforms/with-handlers/check form expected)] (check-subforms/with-handlers/check form expected)]
[stx [stx
#:when (ignore-some-property form) #:when (ignore-some-property form)
@ -266,8 +266,7 @@
;; kw/opt function def ;; kw/opt function def
[(let-values ([(_) fun]) [(let-values ([(_) fun])
. body) . body)
#:when (or (syntax-property form 'kw-lambda) #:when (or (kw-lambda-property form) (opt-lambda-property form))
(syntax-property form 'opt-lambda))
(match expected (match expected
[(tc-result1: (and f (or (Function: _) [(tc-result1: (and f (or (Function: _)
(Poly: _ (Function: _))))) (Poly: _ (Function: _)))))
@ -305,7 +304,7 @@
#:literals (#%app lambda find-method/who) #:literals (#%app lambda find-method/who)
;; ;;
[stx [stx
#:when (syntax-property form 'typechecker:with-handlers) #:when (with-handlers-property form)
(let ([ty (check-subforms/with-handlers form)]) (let ([ty (check-subforms/with-handlers form)])
(unless ty (unless ty
(int-err "internal error: with-handlers")) (int-err "internal error: with-handlers"))

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

@ -4,7 +4,7 @@
(only-in srfi/1/list s:member) (only-in srfi/1/list s:member)
(except-in (types utils abbrev union) -> ->* one-of/c) (except-in (types utils abbrev union) -> ->* one-of/c)
(only-in (types abbrev) (-> t:->)) (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) (env lexical-env type-alias-env global-env type-env-structs scoped-tvar-env)
(rep type-rep filter-rep object-rep) (rep type-rep filter-rep object-rep)
syntax/free-vars syntax/free-vars
@ -216,10 +216,10 @@
(define ((tc-expr-t/maybe-expected expected) e) (define ((tc-expr-t/maybe-expected expected) e)
(syntax-parse e #:literals (#%plain-lambda) (syntax-parse e #:literals (#%plain-lambda)
[(#%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))))] (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/check e expected)]
[_ (tc-expr e)])) [_ (tc-expr e)]))

4
collects/typed-racket/typecheck/tc-structs.rkt
View File

@ -6,7 +6,7 @@
(prefix-in c: (contract-req)) (prefix-in c: (contract-req))
(rep type-rep object-rep free-variance) (rep type-rep object-rep free-variance)
(private parse-type) (private parse-type syntax-properties)
(types abbrev utils union resolve substitute type-table) (types abbrev utils union resolve substitute type-table)
(env global-env type-env-structs type-name-env tvar-env) (env global-env type-env-structs type-name-env tvar-env)
(utils tc-utils) (utils tc-utils)
@ -280,7 +280,7 @@
(and proc-ty (parse-type proc-ty)))) (and proc-ty (parse-type proc-ty))))
(define sty (mk/inner-struct-type names desc concrete-parent)) (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 ;; register a struct type

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

@ -159,7 +159,7 @@
(let* ([vars (syntax->list #'(var ...))]) (let* ([vars (syntax->list #'(var ...))])
(cond (cond
;; if all the variables have types, we stick them into the environment ;; 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)]) (let ([ts (map (λ (x) (get-type x #:infer #f)) vars)])
(for-each register-type-if-undefined vars ts) (for-each register-type-if-undefined vars ts)
(map make-def-binding vars ts))] (map make-def-binding vars ts))]

4
collects/typed-racket/typed-reader.rkt
View File

@ -2,6 +2,8 @@
;; Provides raise-read-error and raise-read-eof-error ;; Provides raise-read-error and raise-read-eof-error
(require syntax/readerr) (require syntax/readerr)
(require "private/syntax-properties.rkt")
(define (skip-whitespace port) (define (skip-whitespace port)
;; Skips whitespace characters, sensitive to the current ;; Skips whitespace characters, sensitive to the current
@ -37,7 +39,7 @@
(case (syntax-e next) (case (syntax-e next)
;; type annotation ;; type annotation
[(:) (skip-whitespace port) [(:) (skip-whitespace port)
(syntax-property name 'type-label (syntax->datum (read-one)))] (type-label-property name (syntax->datum (read-one)))]
[(::) (skip-whitespace port) [(::) (skip-whitespace port)
(datum->syntax name `(ann ,name : ,(read-one)))] (datum->syntax name `(ann ,name : ,(read-one)))]
[(@) (let ([elems (let loop ([es '()]) [(@) (let ([elems (let loop ([es '()])