From b0ba3272cb7dadba24b0bcba73128bef3f312d06 Mon Sep 17 00:00:00 2001
From: Asumu Takikawa <asumu@ccs.neu.edu>
Date: Wed, 5 Mar 2014 01:34:31 -0500
Subject: [PATCH] Improve TR's check for by-name superclass inits

Make sure to check that by-name inits are actually accepted
by the superclass and produce a good error when they aren't.
---
 .../typecheck/check-class-unit.rkt            | 24 ++++++++++---------
 .../typed-racket/unit-tests/class-tests.rkt   |  3 +++
 2 files changed, 16 insertions(+), 11 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 155ec6562f..23ce3b82c7 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
@@ -366,7 +366,8 @@
                           augment-annotation-table)
 
   ;; Calculate remaining inits, optional inits, etc.
-  ;;
+  (check-by-name super-new super-inits)
+
   ;; super-init-rest* - The init-rest passed to the `infer-self-type` function.
   ;;                    This reflects any changes to the `super-init-rest` type
   ;;                    that are necessary due to the super constructor call in
@@ -1144,14 +1145,17 @@
                      (cons name val)))]))
 
 ;; check-by-name : super-init-stxs Dict -> Void
-;; Check by-name inits for duplicates
+;; Check that by-name inits are valid for the superclass
 (define (check-by-name init-stxs super-inits)
   (match-define (super-init-stxs _ by-name) init-stxs)
-  (for/and ([(name _) (in-dict by-name)])
-    (and (dict-ref super-inits name #f)
-         (tc-error/expr "super-new: init argument ~a not accepted by superclass"
-                        name
-                        #:return #f))))
+  (for ([(name _) (in-dict by-name)])
+    (unless (dict-ref super-inits name #f)
+      (tc-error/expr/fields
+       "invalid `super-new' or `super-instantiate'"
+       #:more "init argument not accepted by superclass"
+       "init name" name
+       #:stx #`#,name
+       #:return #f))))
 
 ;; check-super-new : super-init-stxs Dict Type -> Void
 ;; Check if the super-new call is well-typed
@@ -1180,10 +1184,8 @@
            (tc-expr/check pos-arg (ret type)))
          (for ([(init-id init-arg) (in-dict provided-inits)])
            (define maybe-expected (dict-ref remaining-inits init-id #f))
-           (if maybe-expected
-               (tc-expr/check init-arg (ret (car maybe-expected)))
-               (tc-error/expr "init argument ~a not accepted by superclass"
-                              init-id)))]))
+           (when maybe-expected
+             (tc-expr/check init-arg (ret (car maybe-expected)))))]))
 
 ;; Syntax (Syntax -> Any) -> Listof<Syntax>
 ;; Look through the expansion of the class macro in search for
diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt
index 4e23fdce45..b5ba0cece7 100644
--- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt
+++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt
@@ -547,6 +547,9 @@
              (: x String)
              (init x)
              (super-new [x x]))]
+   ;; fails, superclass does not accept this init arg
+   [tc-err (class object% (super-new [x 3]))
+           #:msg "not accepted by superclass"]
    ;; test inherit method
    [tc-e (let ()
            (class (class object% (super-new)