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 996d77dfb9..e15bc69697 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 @@ -225,24 +225,7 @@ non-clause?)) (define name-dict (extract-names clauses)) (define-values (annotated-methods other-top-level) - (for/fold ([methods '()] - [rest-top '()]) - ([other others]) - (define stx (non-clause-stx other)) - (syntax-parse stx - ;; if it's a method definition for a declared method, then - ;; mark it as something to type-check - [(define-values (id) . rst) - #:when (memf (λ (n) (free-identifier=? #'id n)) - (dict-ref name-dict #'public)) - (values (cons (non-clause (syntax-property stx - 'tr:class:method - (syntax-e #'id))) - methods) - rest-top)] - ;; FIXME: this needs to handle external/internal names too - ;; FIXME: this needs to track overrides and other things - [_ (values methods (append rest-top (list other)))]))) + (process-class-contents others name-dict)) (define annotated-super (syntax-property #'super 'tr:class:super #t)) (syntax-property @@ -267,6 +250,35 @@ 'typechecker:ignore #t)])])) (begin-for-syntax + ;; process-class-contents : Listof Dict> + ;; -> Listof Listof + ;; Process methods and other top-level expressions and definitions + ;; that aren't class clauses like `init` or `public` + (define (process-class-contents contents name-dict) + (for/fold ([methods '()] + [rest-top '()]) + ([content contents]) + (define stx (non-clause-stx content)) + (syntax-parse stx + #:literals (define-values super-new) + ;; if it's a method definition for a declared method, then + ;; mark it as something to type-check + ;; FIXME: this needs to handle external/internal names too + ;; FIXME: this needs to track overrides and other things + [(define-values (id) . rst) + #:when (memf (λ (n) (free-identifier=? #'id n)) + (dict-ref name-dict #'public)) + (values (cons (non-clause (syntax-property stx + 'tr:class:method + (syntax-e #'id))) + methods) + rest-top)] + ;; Identify super-new for the benefit of the type checker + [(super-new [init-id init-expr] ...) + (define new-non-clause + (non-clause (syntax-property stx 'tr:class:super-new #t))) + (values methods (append rest-top (list new-non-clause)))] + [_ (values methods (append rest-top (list content)))]))) ;; This is a neat/horrible trick ;; ;; In order to detect the mappings that class-internal.rkt has 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 9b6ab02410..6b0305f3c5 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 @@ -145,6 +145,9 @@ (map cons (syntax->datum #'(method ...)) (syntax->list #'(local-method ...)))])) + ;; find the `super-new` call (or error if missing) + (define super-new-stx (trawl-for-property #'body 'tr:class:super-new)) + (check-super-new super-new-stx super-inits) ;; trawl the body and find methods and type-check them (define meths (trawl-for-property #'body 'tr:class:method)) (with-lexical-env/extend (map (λ (m) (dict-ref local-table m)) @@ -172,6 +175,28 @@ (define top-level-exprs (trawl-for-property #'body 'tr:class:top-level)) (void)])) +;; check-super-new : Listof Inits -> Void +;; Check if the super-new call is well-typed +(define (check-super-new super-new-stx super-inits) + (cond [(null? super-new-stx) + (tc-error/expr + "typed classes must call super-new at the class top-level")] + [else + (syntax-parse (car super-new-stx) + #:literals (#%plain-app list cons quote) + [(#%plain-app super-go _ _ _ _ _ + (#%plain-app + list + (#%plain-app cons (quote init-id) arg:expr) + ...)) + (for ([init-id (syntax->datum #'(init-id ...))] + [init-arg (syntax->list #'(arg ...))]) + (define maybe-expected (dict-ref super-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)))])])) + ;; Syntax -> Listof ;; Look through the expansion of the class macro in search for ;; syntax with some property (e.g., methods) 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 3430aa0709..a263447b47 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 @@ -235,5 +235,29 @@ (public m) (define-values (m) (lambda (x) (number->string x))))]) - (send (new c%) m 4))))) + (send (new c%) m 4))) + + ;; check a good super-new call + (check-ok + (: c% (Class (init [x Integer]))) + (define c% (class: object% (super-new) (init x))) + (: d% (Class)) + (define d% (class: c% (super-new [x (+ 3 5)])))) + + ;; fails, missing super-new + (check-err + (: c% (Class (init [x Integer]))) + (define c% (class: object% (init x)))) + + ;; fails, non-top-level super-new + (check-err + (: c% (Class (init [x Integer]))) + (define c% (class: object% (let () (super-new)) (init x)))) + + ;; fails, bad super-new argument + (check-err + (: c% (Class (init [x Integer]))) + (define c% (class: object% (super-new) (init x))) + (: d% (Class)) + (define d% (class: c% (super-new [x "bad"]))))))