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 e15bc69697..465c5746fc 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 @@ -238,7 +238,8 @@ (init #,@(dict-ref name-dict #'init '())) (init-field #,@(dict-ref name-dict #'init-field '())) (field #,@(dict-ref name-dict #'field '())) - (public #,@(dict-ref name-dict #'public '())))) + (public #,@(dict-ref name-dict #'public '())) + (override #,@(dict-ref name-dict #'override '())))) (class #,annotated-super #,@(map clause-stx clauses) #,@(map non-clause-stx annotated-methods) @@ -264,10 +265,11 @@ ;; 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 + ;; FIXME: this needs to track privates, augments, etc. [(define-values (id) . rst) #:when (memf (λ (n) (free-identifier=? #'id n)) - (dict-ref name-dict #'public)) + (append (dict-ref name-dict #'public '()) + (dict-ref name-dict #'override '()))) (values (cons (non-clause (syntax-property stx 'tr:class:method (syntax-e #'id))) @@ -288,10 +290,13 @@ ;; set!-transformers to the appropriate accessors, which lets ;; us figure out the accessor identifiers. (define (make-locals-table name-dict) - (syntax-property - #`(let-values ([(#,@(dict-ref name-dict #'public '())) - (values #,@(map (λ (stx) #`(λ () (#,stx))) - (dict-ref name-dict #'public '())))]) - (void)) - 'tr:class:local-table #t))) + (define method-names + (append (dict-ref name-dict #'public '()) + (dict-ref name-dict #'override '()))) + (syntax-property + #`(let-values ([(#,@method-names) + (values #,@(map (λ (stx) #`(λ () (#,stx))) + method-names))]) + (void)) + 'tr:class:local-table #t))) 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 6b0305f3c5..21b106e5f2 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 @@ -48,7 +48,7 @@ (syntax-parse form #:literals (let-values #%plain-lambda quote-syntax begin #%plain-app values class:-internal letrec-syntaxes+values - c:init c:init-field c:field c:public) + c:init c:init-field c:field c:public c:override) ;; Inspect the expansion of the class macro for the pieces that ;; we need to type-check like superclass, methods, top-level ;; expressions and so on @@ -63,7 +63,8 @@ (c:init internal-init-names ...) (c:init-field internal-init-field-names ...) (c:field internal-field-names ...) - (c:public internal-public-names ...))) + (c:public internal-public-names ...) + (c:override internal-override-names ...))) (#%plain-app values)))) (let-values (((superclass) superclass-expr) ((interfaces) interface-expr)) @@ -103,8 +104,12 @@ (list->set (append (syntax->datum #'(internal-field-names ...)) (syntax->datum #'(internal-init-field-names ...))))) - (define this%-method-names + (define this%-public-names (list->set (syntax->datum #'(internal-public-names ...)))) + (define this%-override-names + (list->set (syntax->datum #'(internal-override-names ...)))) + (define this%-method-names + (set-union this%-public-names this%-override-names)) ;; Use the internal class: information to check whether clauses ;; exist or are absent appropriately (when expected? @@ -114,20 +119,22 @@ (check-exists (set-union this%-init-names super-init-names) exp-init-names "initialization argument") - (check-exists (set-union this%-method-names super-method-names) + (check-exists (set-union this%-public-names super-method-names) exp-method-names "public method") (check-exists (set-union this%-field-names super-field-names) exp-field-names "public field")) + (check-exists super-method-names this%-override-names + "override method") (check-absent super-field-names this%-field-names "public field") - (check-absent super-method-names this%-method-names "public method") + (check-absent super-method-names this%-public-names "public method") ;; FIXME: the control flow for the failure of these checks is ;; still up in the air #| (check-no-extra (set-union this%-field-names super-field-names) exp-field-names) - (check-no-extra (set-union this%-method-names super-method-names) + (check-no-extra (set-union this%-public-names super-method-names) exp-method-names) |# ;; trawl the body for the local name table @@ -151,7 +158,7 @@ ;; 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)) - (syntax->datum #'(internal-public-names ...))) + (set->list this%-method-names)) ;; FIXME: the types we put here are fine in the expected ;; case, but not if the class doesn't have an annotation. ;; Then we need to hunt down annotations in a first pass. @@ -161,7 +168,7 @@ (map (λ (m) (->* (list (make-Univ)) (fixup-method-type (car (dict-ref methods m)) self-type))) - (syntax->datum #'(internal-public-names ...))) + (set->list this%-method-names)) (for ([meth meths]) (define method-name (syntax-property meth 'tr:class:method)) (define method-type 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 a263447b47..7dd295bae5 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 @@ -259,5 +259,31 @@ (: c% (Class (init [x Integer]))) (define c% (class: object% (super-new) (init x))) (: d% (Class)) - (define d% (class: c% (super-new [x "bad"])))))) + (define d% (class: c% (super-new [x "bad"])))) + + ;; test override + (check-ok + (: c% (Class [m (Integer -> Integer)])) + (define c% (class: object% (super-new) + (define/public (m y) (add1 y)))) + (: d% (Class [m (Integer -> Integer)])) + (define d% (class: c% (super-new) + (define/override (m y) (* 2 y))))) + + ;; test local call to overriden method + (check-ok + (: c% (Class [m (Integer -> Integer)])) + (define c% (class: object% (super-new) + (define/public (m y) (add1 y)))) + (: d% (Class [n (Integer -> Integer)] + [m (Integer -> Integer)])) + (define d% (class: c% (super-new) + (define/public (n x) (m x)) + (define/override (m y) (* 2 y))))) + + ;; fails, superclass missing public for override + (check-err + (: d% (Class [m (Integer -> Integer)])) + (define d% (class: object% (super-new) + (define/override (m y) (* 2 y)))))))