From 7c87a975a6fc28c0d395d0d6144467ad0bd00f00 Mon Sep 17 00:00:00 2001
From: Eric Dobson <eric.n.dobson@gmail.com>
Date: Sat, 25 May 2013 14:32:11 -0700
Subject: [PATCH] Remove unnecessary loop in tc-app-objects.

---
 .../typecheck/tc-app/tc-app-objects.rkt       | 70 +++++++++----------
 1 file changed, 34 insertions(+), 36 deletions(-)

diff --git a/collects/typed-racket/typecheck/tc-app/tc-app-objects.rkt b/collects/typed-racket/typecheck/tc-app/tc-app-objects.rkt
index c969aca625..6c893642ea 100644
--- a/collects/typed-racket/typecheck/tc-app/tc-app-objects.rkt
+++ b/collects/typed-racket/typecheck/tc-app/tc-app-objects.rkt
@@ -6,7 +6,7 @@
          syntax/parse syntax/stx racket/match unstable/sequence unstable/syntax
          syntax/parse/experimental/reflect racket/dict
          (typecheck signatures tc-funapp)
-         (types abbrev union utils)
+         (types abbrev resolve union utils)
          (rep type-rep)
          (utils tc-utils)
 
@@ -33,38 +33,36 @@
 (define (check-do-make-object b cl pos-args names named-args)
   (let* ([names (stx-map syntax-e names)]
          [name-assoc (stx-map cons names named-args)])
-    (let loop ([t (tc-expr cl)])
-      (match t
-        [(tc-result1: (? Mu? t*)) (loop (ret (unfold t*)))]
-        [(tc-result1: (Union: '())) (ret (Un))]
-        [(tc-result1: (and c (Class: pos-tys (list (and tnflds (list tnames _ _)) ...) _)))
-         (unless (= (length pos-tys)
-                    (syntax-length pos-args))
-           (tc-error/delayed "expected ~a positional arguments, but got ~a"
-                             (length pos-tys) (syntax-length pos-args)))
-         ;; use for, since they might be different lengths in error case
-         (for ([pa (in-syntax pos-args)]
-               [pt (in-list pos-tys)])
-           (tc-expr/check pa (ret pt)))
-         (for ([n (in-list names)]
-               #:unless (memq n tnames))
-           (tc-error/delayed
-            "unknown named argument ~a for class\nlegal named arguments are ~a"
-            n (stringify tnames)))
-         (for-each (match-lambda
-                     [(list tname tfty opt?)
-                      (define s
-                        (dict-ref name-assoc tname
-                          (lambda ()
-                            (unless opt?
-                              (tc-error/delayed "value not provided for named init arg ~a"
-                                                tname))
-                            #f)))
-                      ;; Only check the argument if it is provided
-                      (when s
-                        (tc-expr/check s (ret tfty)))])
-                   tnflds)
-         (ret (make-Instance c))]
-        [(tc-result1: t)
-         (tc-error/expr #:return (ret (Un))
-                        "expected a class value for object creation, got: ~a" t)]))))
+    (match (resolve (tc-expr/t cl))
+      [(Union: '()) (ret (Un))]
+      [(and c (Class: pos-tys (list (and tnflds (list tnames _ _)) ...) _))
+       (unless (= (length pos-tys)
+                  (syntax-length pos-args))
+         (tc-error/delayed "expected ~a positional arguments, but got ~a"
+                           (length pos-tys) (syntax-length pos-args)))
+       ;; use for, since they might be different lengths in error case
+       (for ([pa (in-syntax pos-args)]
+             [pt (in-list pos-tys)])
+         (tc-expr/check pa (ret pt)))
+       (for ([n (in-list names)]
+             #:unless (memq n tnames))
+         (tc-error/delayed
+          "unknown named argument ~a for class\nlegal named arguments are ~a"
+          n (stringify tnames)))
+       (for-each (match-lambda
+                   [(list tname tfty opt?)
+                    (define s
+                      (dict-ref name-assoc tname
+                        (lambda ()
+                          (unless opt?
+                            (tc-error/delayed "value not provided for named init arg ~a"
+                                              tname))
+                          #f)))
+                    ;; Only check the argument if it is provided
+                    (when s
+                      (tc-expr/check s (ret tfty)))])
+                 tnflds)
+       (ret (make-Instance c))]
+      [t
+       (tc-error/expr #:return (ret (Un))
+                      "expected a class value for object creation, got: ~a" t)])))