From 94535805cdcac0cc6b1888e6eb7c42f3f5082f32 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Wed, 22 May 2013 13:25:55 -0400 Subject: [PATCH] Type-check field initialization Also fixed local accessors when internal names are used that are different from external names. original commit: 267a37134ef164f7d8bd9e3ffe6006ab16cf4bf2 --- .../typecheck/check-class-unit.rkt | 65 +++++++++++++------ .../typed-racket/unit-tests/class-tests.rkt | 16 +++++ 2 files changed, 61 insertions(+), 20 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 66461271..3a94a6c5 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 @@ -60,12 +60,14 @@ #:with private-names #'(privates ...))) (define-syntax-class initializer-body - #:literals (let-values) + #:literals (letrec-syntaxes+values) #:attributes (val) - (pattern (let-values () body:initializer-body) + (pattern (letrec-syntaxes+values _ _ body:initializer-body) #:with val #'body.val) - (pattern (e:expr ...) - #:with val #'(e ...))) + (pattern (letrec-syntaxes+values _ _ + (~and e0 (~not letrec-syntaxes+values)) + e:expr ...) + #:with val #'(e0 e ...))) (define-syntax-class initializer-class #:literals (#%plain-lambda) @@ -79,19 +81,18 @@ (define-syntax-class make-methods-body #:literals (let-values letrec-syntaxes+values #%plain-app values) #:attributes (initializer-body) - (pattern (let-values () body:make-methods-body) - #:with initializer-body #'body.initializer-body) - (pattern (letrec-syntaxes+values _ _ body) - #:with initializer-body #'body.initializer-body) - (pattern (letrec-syntaxes+values - _ _ + (pattern (letrec-values _ (#%plain-app values public:expr override:expr augride:expr initializer:initializer-class)) - #:with initializer-body #'initializer.val)) + #:with initializer-body #'initializer.val) + (pattern (let-values () body:make-methods-body) + #:with initializer-body #'body.initializer-body) + (pattern (letrec-syntaxes+values _ _ body:make-methods-body) + #:with initializer-body #'body.initializer-body)) (define-syntax-class make-methods-class #:literals (let-values #%plain-lambda) @@ -258,7 +259,8 @@ (values name type))) ;; start type-checking elements in the body (define-values (lexical-names lexical-types) - (local-tables->lexical-env local-method-table methods + (local-tables->lexical-env internal-external-mapping + local-method-table methods this%-method-internals local-field-table fields this%-field-internals @@ -269,6 +271,8 @@ (for ([stx top-level-exprs] #:unless (syntax-property stx 'tr:class:super-new)) (tc-expr stx))) + (with-lexical-env/extend lexical-names lexical-types + (check-field-set!s #'cls.initializer-body local-field-table)) ;; trawl the body and find methods and type-check them (define meths (trawl-for-property #'cls.make-methods 'tr:class:method)) (define checked-method-types @@ -338,7 +342,8 @@ (dict-set methods name type))) (make-Class #f inits fields new-methods)) -;; local-tables->lexical-env : Dict Dict List +;; local-tables->lexical-env : Dict +;; Dict Dict List ;; Dict Dict List ;; Type ;; -> List List @@ -349,7 +354,8 @@ ;; case, but not if the class doesn't have an annotation. ;; Then we need to hunt down annotations in a first pass. ;; (should probably do this in expected case anyway) -(define (local-tables->lexical-env local-method-table methods method-names +(define (local-tables->lexical-env internal-external-mapping + local-method-table methods method-names local-field-table fields field-names local-private-table private-types private-methods @@ -369,22 +375,24 @@ ;; construct the types for the accessors (define method-types (for/list ([m (in-set method-names)]) - (define maybe-type (dict-ref methods m #f)) + (define external (dict-ref internal-external-mapping m)) + (define maybe-type (dict-ref methods external #f)) (->* (list (make-Univ)) (if maybe-type (fixup-method-type (car maybe-type) self-type) (make-Univ))))) (define field-get-types (for/list ([f (in-set field-names)]) - (define maybe-type (dict-ref fields f #f)) + (define external (dict-ref internal-external-mapping f)) + (define maybe-type (dict-ref fields external #f)) (->* (list (make-Univ)) (or (and maybe-type (car maybe-type)) (make-Univ))))) (define field-set-types (for/list ([f (in-set field-names)]) - (define maybe-type (dict-ref fields f #f)) - (->* (list (make-Univ) (or (and maybe-type - (car maybe-type)) - -bot)) + (define external (dict-ref internal-external-mapping f)) + (define maybe-type (dict-ref fields external #f)) + (->* (list (make-Univ) (or (and maybe-type (car maybe-type)) + -Bottom)) -Void))) (define private-method-types (for/list ([f (in-set private-methods)]) @@ -418,6 +426,23 @@ [else (list external-name (unfixup-method-type (tc-expr/t meth)))]))) +;; check-field-set!s : Syntax Dict -> Void +;; Check that fields are initialized to the correct type +(define (check-field-set!s stx local-field-table) + (for ([form (syntax->list stx)]) + (syntax-parse form + #:literals (let-values #%plain-app) + ;; FIXME: could use the local table to make sure the + ;; setter is known as a sanity check + [(let-values (((obj1:id) self:id)) + (let-values (((x:id) init-val:expr)) + (#%plain-app local-setter:id obj2:id y:id))) + #:when (free-identifier=? #'x #'y) + #:when (free-identifier=? #'obj1 #'obj2) + (with-lexical-env/extend (list #'self) (list (make-Univ)) + (tc-expr form))] + [_ (void)]))) + ;; Syntax -> Dict Dict ;; Construct tables mapping internal method names to the accessors ;; generated inside the untyped class macro. 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 81cb0e9e..6f38bef7 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 @@ -106,6 +106,12 @@ (field [n 0]) (define/public (m) (get-field n this))))) + ;; fails, field's default value has wrong type + (check-err + (class: object% (super-new) + (: x Integer) + (field [x "foo"]))) + ;; Fail, field access to missing field (check-err (: k% (Class (field [n Integer]) @@ -429,6 +435,16 @@ (define m (lambda () 0)))) (send (new c%) n)) + ;; test local calls with internal/external + (check-ok + (define c% (class: object% (super-new) + (: m (-> Integer)) + (public [m n]) + (define m (lambda () 0)) + (: z (-> Integer)) + (define/public (z) (m)))) + (send (new c%) z)) + ;; internal/external the same is ok (check-ok (define c% (class: object% (super-new)