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

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

@ -375,9 +375,11 @@
(for/list ([id ids] [type types] (for/list ([id ids] [type types]
#:when type) #:when type)
(syntax-property (syntax-property
#`(: #,(if (stx-pair? id) (stx-car id) id) (syntax-property
#,type) #`(: #,(if (stx-pair? id) (stx-car id) id)
'tr:class:top-level #t)))) #,type)
'tr:class:top-level #t)
'tr:class:type-annotation #t))))
#,@(map non-clause-stx annotated-methods) #,@(map non-clause-stx annotated-methods)
#,(syntax-property #,(syntax-property
#`(begin #,@(map non-clause-stx other-top-level)) #`(begin #,@(map non-clause-stx other-top-level))
@ -422,12 +424,22 @@
;; special : annotation for augment interface ;; special : annotation for augment interface
[(: name:id type:expr #:augment augment-type:expr) [(: name:id type:expr #:augment augment-type:expr)
(define new-clause (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 (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 (values methods
(append rest-top (list plain-annotation new-clause)) (append rest-top (list plain-annotation new-clause))
private-fields)] 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 ;; Identify super-new for the benefit of the type checker
[(super-new [init-id init-expr] ...) [(super-new [init-id init-expr] ...)
(define new-non-clause (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 (with-lexical-env/extend lexical-names/top-level lexical-types/top-level
(check-super-new provided-super-inits super-inits)) (check-super-new provided-super-inits super-inits))
(do-timestamp "checked super-new") (do-timestamp "checked super-new")
(do-timestamp top-level-exprs)
(with-lexical-env/extend lexical-names/top-level lexical-types/top-level (with-lexical-env/extend lexical-names/top-level lexical-types/top-level
(for ([stx top-level-exprs] (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))) (tc-expr stx)))
(do-timestamp "checked other top-level exprs") (do-timestamp "checked other top-level exprs")
(with-lexical-env/extend lexical-names/top-level lexical-types/top-level (with-lexical-env/extend lexical-names/top-level lexical-types/top-level