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

41
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,18 +66,19 @@
[else #f]))
(define (remove-ascription stx)
(syntax-property stx type-ascrip-symbol
(cond
[(syntax-property stx type-ascrip-symbol)
=>
(lambda (prop)
(if (pair? prop)
(let loop ((prop (cdr prop)) (last (car prop)))
(if (pair? prop)
(cons last (loop (cdr prop) (car prop)))
last))
#f))]
[else #f])))
(type-ascription-property
stx
(cond
[(type-ascription-property stx)
=>
(lambda (prop)
(if (pair? prop)
(let loop ((prop (cdr prop)) (last (car prop)))
(if (pair? prop)
(cons last (loop (cdr prop) (car prop)))
last))
#f))]
[else #f])))
;; get the type annotation of this identifier, otherwise error
;; if #:default is provided, return that instead of error
@ -148,5 +143,5 @@
(tc-error "Body had type:\n~a\nVariable had type:\n~a\n" e-type ty))))
(define (dotted? stx)
(cond [(syntax-property stx type-dotted-symbol) => syntax-e]
(cond [(type-dotted-property stx) => syntax-e]
[else #f]))

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

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