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
(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]"

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)
#'(#: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

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

@ -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

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
(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])])

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

@ -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)
)

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

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

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

@ -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)

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

@ -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)

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

@ -7,6 +7,7 @@
syntax/parse/experimental/reflect
(typecheck signatures tc-funapp)
(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.

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

@ -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"))

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

@ -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)]))

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

@ -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

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

@ -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))]

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

@ -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 '()])