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

Add support for override

Browse Source
This commit is contained in:
Asumu Takikawa 2013-05-18 14:17:06 -04:00
parent 060aaa8b26
commit 931556264e
3 changed files with 56 additions and 18 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/base-env/class-prims.rkt
View File

@ -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)))

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

@ -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

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

@ -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)))))))