From 03c74a16ff0c9f8707361e0818b37c99ae5d00d9 Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Mon, 26 Aug 2013 14:19:46 -0400
Subject: [PATCH] Simplify typechecking for some field initializers

This seems to speed up type-checking for some
initializers. The caveat is that it's slightly less
paranoid about type-checking the expansion.
---
 .../typecheck/check-class-unit.rkt            | 30 +++----------------
 1 file changed, 4 insertions(+), 26 deletions(-)

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 c3b8c4a6b1..2415bdfc0e 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
@@ -791,18 +791,6 @@
        (define init-name (syntax-e #'init-external))
        (define init-type (car (dict-ref inits init-name '(#f))))
        (cond [init-type
-              ;; This is a type for the internal `extract-args` function
-              ;; that extracts init arguments from the object. We just
-              ;; want to make sure that init argument default value
-              ;; (the last argument) matches the type for the init.
-              ;;
-              ;; The rest is plumbing to make the type system happy.
-              (define extract-arg-type
-                (cl->* (->* (list (Un (-val #f) -Symbol) (-val init-name)
-                                  (make-Univ) (-val #f)) init-type)
-                       (->* (list (Un (-val #f) -Symbol) (-val init-name)
-                                  (make-Univ) (->* '() init-type))
-                            init-type)))
               ;; Catch the exception because the error that is produced
               ;; in the case of a type error is incomprehensible for a
               ;; programmer looking at surface syntax. Raise a custom
@@ -811,10 +799,8 @@
                   ([exn:fail:syntax?
                     (λ (e) (tc-error/expr "Default init value has wrong type"))])
                 (parameterize ([delay-errors? #f])
-                  (with-lexical-env/extend
-                   (list #'extract-arg)
-                   (list extract-arg-type)
-                   (tc-expr form))))]
+                  (unless (equal? (syntax->datum #'init-val) '(quote #f))
+                    (tc-expr/check #'init-val (ret (Un init-type (->* null init-type)))))))]
              ;; If the type can't be found, it means that there was no
              ;; expected type or no annotation was provided via (: ...).
              ;;
@@ -838,21 +824,13 @@
        (define init-name (syntax-e #'name))
        (define init-type (car (dict-ref inits init-name '(#f))))
        (cond [init-type
-              (define extract-arg-type
-                (cl->* (->* (list (Un (-val #f) -Symbol) (-val init-name)
-                                  (make-Univ) (-val #f)) init-type)
-                       (->* (list (Un (-val #f) -Symbol) (-val init-name)
-                                  (make-Univ) (->* '() init-type))
-                            init-type)))
               (with-handlers
                   ([exn:fail:syntax?
                     ;; FIXME: produce a better error message
                     (λ (e) (tc-error/expr "Default init value has wrong type"))])
                 (parameterize ([delay-errors? #f])
-                  (with-lexical-env/extend
-                   (list #'extract-arg)
-                   (list extract-arg-type)
-                   (tc-expr form))))]
+                  (unless (equal? (syntax->datum #'init-val) '(quote #f))
+                    (tc-expr/check #'init-val (ret (Un init-type (->* null init-type)))))))]
              [else
               (tc-error/expr "Init argument ~a has no type annotation"
                              init-name)])]