From aa830a346123fdc092a4bceddfaf0276ab6e096c Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Wed, 22 May 2013 17:10:51 -0400 Subject: [PATCH] Get init-field working in most cases --- .../typecheck/check-class-unit.rkt | 39 ++++++++++++++++--- .../typed-racket/unit-tests/class-tests.rkt | 12 ++++++ 2 files changed, 46 insertions(+), 5 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 3a94a6c517..88b84c169f 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 @@ -181,7 +181,8 @@ (define this%-method-internals (set-union this%-public-internals this%-override-internals)) (define this%-field-internals - (list->set (syntax->datum #'cls.field-internals))) + (list->set (append (syntax->datum #'cls.field-internals) + (syntax->datum #'cls.init-field-internals)))) (define this%-init-names (list->set (append (syntax->datum #'cls.init-externals) @@ -272,7 +273,7 @@ #: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)) + (check-field-set!s #'cls.initializer-body local-field-table inits)) ;; 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 @@ -426,12 +427,40 @@ [else (list external-name (unfixup-method-type (tc-expr/t meth)))]))) -;; check-field-set!s : Syntax Dict -> Void +;; check-field-set!s : Syntax Dict Dict -> Void ;; Check that fields are initialized to the correct type -(define (check-field-set!s stx local-field-table) +(define (check-field-set!s stx local-field-table inits) (for ([form (syntax->list stx)]) (syntax-parse form - #:literals (let-values #%plain-app) + #:literals (let-values #%plain-app quote) + ;; init-field case + [(let-values (((obj1:id) self:id)) + (let-values (((x:id) + (#%plain-app extract-arg:id + _ + (quote name:id) + init-args:id + init-val:expr))) + (#%plain-app local-setter:id obj2:id y:id))) + #:when (free-identifier=? #'x #'y) + #:when (free-identifier=? #'obj1 #'obj2) + (define init-name (syntax-e #'name)) + (define init-type (car (dict-ref inits init-name))) + (define extract-arg-type + (cl->* (->* (list (Un (-val #f) -Symbol) (-val init-name) + (make-Univ) (-val #f)) init-type) + (->* (list (Un (-val #f) -Symbol) (-val init-name) + (make-Univ) (->* '() init-type)) + init-type))) + (with-handlers + ([exn:fail:syntax? + ;; FIXME: produce a better error message + (λ (e) (tc-error/expr "Default init value has wrong type"))]) + (parameterize ([delay-errors? #f]) + (with-lexical-env/extend + (list #'self #'init-args #'extract-arg) + (list (make-Univ) (make-Univ) extract-arg-type) + (tc-expr form))))] ;; FIXME: could use the local table to make sure the ;; setter is known as a sanity check [(let-values (((obj1:id) self:id)) 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 6f38bef7a0..4427f3389e 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 @@ -495,6 +495,18 @@ (init ([i j])))) (new c% [i 5])) + ;; test init field default value + (check-ok + (define c% (class: object% (super-new) + (: x Integer) + (init-field ([x y] 0))))) + + ;; fails, wrong init-field default + (check-err + (define c% (class: object% (super-new) + (: x Integer) + (init-field ([x y] "foo"))))) + ;; test type-checking method with internal/external (check-err (: c% (Class [n (Integer -> Integer)]))