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
This commit is contained in:
Eric Dobson 2013-05-25 17:22:34 -07:00
parent a325e38046
commit 4310f04eaf
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)
)

21
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,9 +66,10 @@
[else #f])) [else #f]))
(define (remove-ascription stx) (define (remove-ascription stx)
(syntax-property stx type-ascrip-symbol (type-ascription-property
stx
(cond (cond
[(syntax-property stx type-ascrip-symbol) [(type-ascription-property stx)
=> =>
(lambda (prop) (lambda (prop)
(if (pair? prop) (if (pair? prop)
@ -147,5 +142,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) (typecheck signatures tc-funapp)
(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 '()])