From e52256b7f08e5e4bb5846fd5bbfc2032b46ea45e Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Mon, 26 Aug 2013 14:18:03 -0400
Subject: [PATCH] Avoid type-checking type annotation clauses

---
 .../typed-racket/base-env/class-prims.rkt     | 22 ++++++++++++++-----
 .../typecheck/check-class-unit.rkt            |  6 +++--
 2 files changed, 21 insertions(+), 7 deletions(-)

diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt
index 3296a74c5d..27be5f444e 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt
@@ -375,9 +375,11 @@
                             (for/list ([id ids] [type types]
                                        #:when type)
                               (syntax-property
-                               #`(: #,(if (stx-pair? id) (stx-car id) id)
-                                    #,type)
-                               'tr:class:top-level #t))))
+                               (syntax-property
+                                #`(: #,(if (stx-pair? id) (stx-car id) id)
+                                     #,type)
+                                '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
diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
index 26e3f3850a..61513c1d1d 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
@@ -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