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

Avoid type-checking type annotation clauses

Browse Source
This commit is contained in:
Asumu Takikawa 2013-08-26 14:18:03 -04:00
parent c8e5423e55
commit e52256b7f0
2 changed files with 21 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt
View File

@ -374,10 +374,12 @@
(match-define (clause _1 _2 ids types) a-clause)
(for/list ([id ids] [type types]
#:when type)
(syntax-property
(syntax-property
#`(: #,(if (stx-pair? id) (stx-car id) id)
#,type)
'tr:class:top-level #t))))
'tr:class:top-level #t)
'tr:class:type-annotation #t))))
#,@(map non-clause-stx annotated-methods)
#,(syntax-property
#`(begin #,@(map non-clause-stx other-top-level))
@ -422,12 +424,22 @@
;; special : annotation for augment interface
[(: name:id type:expr #:augment augment-type:expr)
(define new-clause
(non-clause #'(quote-syntax (:-augment name augment-type))))
(non-clause (syntax-property #'(quote-syntax (:-augment name augment-type))
'tr:class:type-annotation #t)))
(define plain-annotation
(non-clause (syntax/loc stx (: name type))))
(non-clause (syntax-property (syntax/loc stx (: name type))
'tr:class:type-annotation #t)))
(values methods
(append rest-top (list plain-annotation new-clause))
private-fields)]
;; Just process this to add the property
[(: name:id type:expr)
(define plain-annotation
(non-clause (syntax-property (syntax/loc stx (: name type))
'tr:class:type-annotation #t)))
(values methods
(append rest-top (list plain-annotation))
private-fields)]
;; Identify super-new for the benefit of the type checker
[(super-new [init-id init-expr] ...)
(define new-non-clause

6
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
View File

@ -400,10 +400,12 @@
(with-lexical-env/extend lexical-names/top-level lexical-types/top-level
(check-super-new provided-super-inits super-inits))
(do-timestamp "checked super-new")
(do-timestamp top-level-exprs)
(with-lexical-env/extend lexical-names/top-level lexical-types/top-level
(for ([stx top-level-exprs]
#:unless (syntax-property stx 'tr:class:super-new))
;; avoid checking these to avoid duplication and to avoid checking
;; ignored expressions
#:unless (syntax-property stx 'tr:class:super-new)
#:unless (syntax-property stx 'tr:class:type-annotation))
(tc-expr stx)))
(do-timestamp "checked other top-level exprs")
(with-lexical-env/extend lexical-names/top-level lexical-types/top-level