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

Fix inheritance without expected type

Browse Source
This commit is contained in:
Asumu Takikawa 2013-05-20 23:16:09 -04:00
parent d8a3039830
commit c16a3b2350
2 changed files with 24 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt
View File

@ -168,6 +168,9 @@
;; trawl the body for top-level expressions ;; trawl the body for top-level expressions
(define top-level-exprs (trawl-for-property #'body 'tr:class:top-level)) (define top-level-exprs (trawl-for-property #'body 'tr:class:top-level))
(define internals-table (register-internals top-level-exprs)) (define internals-table (register-internals top-level-exprs))
;; 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)
;; Type for self in method calls ;; Type for self in method calls
(define self-type (define self-type
(if self-class-type (if self-class-type
@ -175,6 +178,9 @@
(infer-self-type internals-table (infer-self-type internals-table
optional-inits optional-inits
internal-external-mapping internal-external-mapping
super-inits
super-fields
super-methods
this%-init-internals this%-init-internals
this%-field-internals this%-field-internals
this%-public-internals))) this%-public-internals)))
@ -227,9 +233,6 @@
(for ([stx top-level-exprs] (for ([stx top-level-exprs]
#:unless (syntax-property stx 'tr:class:super-new)) #:unless (syntax-property stx 'tr:class:super-new))
(tc-expr stx))) (tc-expr stx)))
;; 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 ;; trawl the body and find methods and type-check them
(define meths (trawl-for-property #'body 'tr:class:method)) (define meths (trawl-for-property #'body 'tr:class:method))
(define checked-method-types (define checked-method-types
@ -428,29 +431,29 @@
[_ table]))) [_ table])))
;; infer-self-type : Dict<Symbol, Type> Set<Symbol> Dict<Symbol, Symbol> ;; infer-self-type : Dict<Symbol, Type> Set<Symbol> Dict<Symbol, Symbol>
;; Inits Fields Methods
;; Set<Symbol> * 3 -> Type ;; Set<Symbol> * 3 -> Type
;; Construct a self object type based on the registered types ;; Construct a self object type based on the registered types
;; from : inside the class body. ;; from : inside the class body.
(define (infer-self-type internals-table optional-inits (define (infer-self-type internals-table optional-inits
internal-external-mapping internal-external-mapping
super-inits super-fields super-methods
inits fields publics) inits fields publics)
(define (make-type-dict names [inits? #f]) (define (make-type-dict names supers [inits? #f])
(for/fold ([type-dict '()]) (for/fold ([type-dict supers])
([name names]) ([name names])
(define external (dict-ref internal-external-mapping name)) (define external (dict-ref internal-external-mapping name))
(cond [(dict-ref internals-table name #f) => (cond [(dict-ref internals-table name #f) =>
(λ (type) (λ (type)
(define entry (define entry
;; FIXME: this should record the correct optional
;; boolean based on internal macro data
(if inits? (if inits?
(list external type (set-member? optional-inits name)) (list external type (set-member? optional-inits name))
(list external type))) (list external type)))
(cons entry type-dict))] (cons entry type-dict))]
[else type-dict]))) [else type-dict])))
(define init-types (make-type-dict inits #t)) (define init-types (make-type-dict inits super-inits #t))
(define field-types (make-type-dict fields)) (define field-types (make-type-dict fields super-fields))
(define public-types (make-type-dict publics)) (define public-types (make-type-dict publics super-methods))
(make-Instance (make-Class #f init-types field-types public-types))) (make-Instance (make-Class #f init-types field-types public-types)))
;; fixup-method-type : Function Type -> Function ;; fixup-method-type : Function Type -> Function

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

@ -424,6 +424,17 @@
(define/public (m) 0))) (define/public (m) 0)))
(send (new c%) m)) (send (new c%) m))
;; test inheritance without expected
(check-ok
(define c% (class: (class: object% (super-new)
(: m (-> Integer))
(define/public (m) 0))
(super-new)
(: n (-> Integer))
(define/public (n) 1)))
(send (new c%) m)
(send (new c%) n))
;; test fields without expected class type ;; test fields without expected class type
(check-ok (check-ok
(define c% (class: object% (super-new) (define c% (class: object% (super-new)