suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Improve TR's check for by-name superclass inits

Browse Source 
Make sure to check that by-name inits are actually accepted
by the superclass and produce a good error when they aren't.
This commit is contained in:
Asumu Takikawa 2014-03-05 01:34:31 -05:00
parent a0ce1fa02c
commit b0ba3272cb
2 changed files with 16 additions and 11 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/typecheck/check-class-unit.rkt
View File

@ -366,7 +366,8 @@
augment-annotation-table) augment-annotation-table)
;; Calculate remaining inits, optional inits, etc. ;; 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. ;; super-init-rest* - The init-rest passed to the `infer-self-type` function.
;; This reflects any changes to the `super-init-rest` type ;; This reflects any changes to the `super-init-rest` type
;; that are necessary due to the super constructor call in ;; that are necessary due to the super constructor call in
@ -1144,13 +1145,16 @@
(cons name val)))])) (cons name val)))]))
;; check-by-name : super-init-stxs Dict -> Void ;; 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) (define (check-by-name init-stxs super-inits)
(match-define (super-init-stxs _ by-name) init-stxs) (match-define (super-init-stxs _ by-name) init-stxs)
(for/and ([(name _) (in-dict by-name)]) (for ([(name _) (in-dict by-name)])
(and (dict-ref super-inits name #f) (unless (dict-ref super-inits name #f)
(tc-error/expr "super-new: init argument ~a not accepted by superclass" (tc-error/expr/fields
name "invalid `super-new' or `super-instantiate'"
#:more "init argument not accepted by superclass"
"init name" name
#:stx #`#,name
#:return #f)))) #:return #f))))
;; check-super-new : super-init-stxs Dict Type -> Void ;; check-super-new : super-init-stxs Dict Type -> Void
@ -1180,10 +1184,8 @@
(tc-expr/check pos-arg (ret type))) (tc-expr/check pos-arg (ret type)))
(for ([(init-id init-arg) (in-dict provided-inits)]) (for ([(init-id init-arg) (in-dict provided-inits)])
(define maybe-expected (dict-ref remaining-inits init-id #f)) (define maybe-expected (dict-ref remaining-inits init-id #f))
(if maybe-expected (when maybe-expected
(tc-expr/check init-arg (ret (car maybe-expected))) (tc-expr/check init-arg (ret (car maybe-expected)))))]))
(tc-error/expr "init argument ~a not accepted by superclass"
init-id)))]))
;; Syntax (Syntax -> Any) -> Listof<Syntax> ;; Syntax (Syntax -> Any) -> Listof<Syntax>
;; Look through the expansion of the class macro in search for ;; Look through the expansion of the class macro in search for

3
pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt
View File

@ -547,6 +547,9 @@
(: x String) (: x String)
(init x) (init x)
(super-new [x 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 ;; test inherit method
[tc-e (let () [tc-e (let ()
(class (class object% (super-new) (class (class object% (super-new)