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

Add support for inherit-field

Browse Source
This commit is contained in:
Asumu Takikawa 2013-08-06 14:23:44 -04:00
parent e25b24986f
commit c16ace02fa
3 changed files with 78 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt
View File

@ -309,6 +309,7 @@
(private #,@(dict-ref name-dict #'private '())) (private #,@(dict-ref name-dict #'private '()))
(private-field #,@private-fields) (private-field #,@private-fields)
(inherit #,@(dict-ref name-dict #'inherit '())) (inherit #,@(dict-ref name-dict #'inherit '()))
(inherit-field #,@(dict-ref name-dict #'inherit-field '()))
(augment #,@(dict-ref name-dict #'augment '())) (augment #,@(dict-ref name-dict #'augment '()))
(pubment #,@(dict-ref name-dict #'pubment '())))) (pubment #,@(dict-ref name-dict #'pubment '()))))
(untyped-class #,annotated-super (untyped-class #,annotated-super
@ -412,6 +413,8 @@
(stx-map stx-car (dict-ref name-dict #'init '()))) (stx-map stx-car (dict-ref name-dict #'init '())))
(define inherit-names (define inherit-names
(stx-map stx-car (dict-ref name-dict #'inherit '()))) (stx-map stx-car (dict-ref name-dict #'inherit '())))
(define inherit-field-names
(stx-map stx-car (dict-ref name-dict #'inherit-field '())))
(define augment-names (define augment-names
(append (stx-map stx-car (dict-ref name-dict #'pubment '())) (append (stx-map stx-car (dict-ref name-dict #'pubment '()))
(stx-map stx-car (dict-ref name-dict #'augment '())))) (stx-map stx-car (dict-ref name-dict #'augment '()))))
@ -428,6 +431,9 @@
[(#,@private-field-names) [(#,@private-field-names)
(values #,@(map (λ (stx) #`(λ () #,stx (set! #,stx 0))) (values #,@(map (λ (stx) #`(λ () #,stx (set! #,stx 0)))
private-field-names))] private-field-names))]
[(#,@inherit-field-names)
(values #,@(map (λ (stx) #`(λ () #,stx (set! #,stx 0)))
inherit-field-names))]
[(#,@init-names) [(#,@init-names)
(values #,@(map (λ (stx) #`(λ () #,stx)) (values #,@(map (λ (stx) #`(λ () #,stx))
init-names))] init-names))]

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

@ -36,8 +36,8 @@
(define-syntax-class internal-class-data (define-syntax-class internal-class-data
#:literals (#%plain-app quote-syntax class-internal begin #:literals (#%plain-app quote-syntax class-internal begin
values c:init c:init-field optional-init c:field values c:init c:init-field optional-init c:field
c:public c:override c:private c:inherit private-field c:public c:override c:private c:inherit c:inherit-field
c:augment c:pubment) private-field c:augment c:pubment)
(pattern (begin (quote-syntax (pattern (begin (quote-syntax
(class-internal (class-internal
(c:init init-names:name-pair ...) (c:init init-names:name-pair ...)
@ -49,6 +49,7 @@
(c:private privates:id ...) (c:private privates:id ...)
(private-field private-fields:id ...) (private-field private-fields:id ...)
(c:inherit inherit-names:name-pair ...) (c:inherit inherit-names:name-pair ...)
(c:inherit-field inherit-field-names:name-pair ...)
(c:augment augment-names:name-pair ...) (c:augment augment-names:name-pair ...)
(c:pubment pubment-names:name-pair ...))) (c:pubment pubment-names:name-pair ...)))
(#%plain-app values)) (#%plain-app values))
@ -65,6 +66,8 @@
#:with override-externals #'(override-names.external ...) #:with override-externals #'(override-names.external ...)
#:with inherit-externals #'(inherit-names.external ...) #:with inherit-externals #'(inherit-names.external ...)
#:with inherit-internals #'(inherit-names.internal ...) #:with inherit-internals #'(inherit-names.internal ...)
#:with inherit-field-externals #'(inherit-field-names.external ...)
#:with inherit-field-internals #'(inherit-field-names.internal ...)
#:with augment-externals #'(augment-names.external ...) #:with augment-externals #'(augment-names.external ...)
#:with augment-internals #'(augment-names.internal ...) #:with augment-internals #'(augment-names.internal ...)
#:with pubment-externals #'(pubment-names.external ...) #:with pubment-externals #'(pubment-names.external ...)
@ -127,6 +130,7 @@
public-internals public-externals public-internals public-externals
override-internals override-externals override-internals override-externals
inherit-internals inherit-externals inherit-internals inherit-externals
inherit-field-internals inherit-field-externals
augment-internals augment-externals augment-internals augment-externals
pubment-internals pubment-externals pubment-internals pubment-externals
private-names private-field-names private-names private-field-names
@ -212,6 +216,8 @@
(syntax->datum #'cls.init-field-internals)))) (syntax->datum #'cls.init-field-internals))))
(define this%-inherit-internals (define this%-inherit-internals
(list->set (syntax->datum #'cls.inherit-internals))) (list->set (syntax->datum #'cls.inherit-internals)))
(define this%-inherit-field-internals
(list->set (syntax->datum #'cls.inherit-field-internals)))
(define this%-init-names (define this%-init-names
(list->set (list->set
(append (syntax->datum #'cls.init-externals) (append (syntax->datum #'cls.init-externals)
@ -230,6 +236,8 @@
(list->set (append (syntax->datum #'cls.augment-externals)))) (list->set (append (syntax->datum #'cls.augment-externals))))
(define this%-inherit-names (define this%-inherit-names
(list->set (syntax->datum #'cls.inherit-externals))) (list->set (syntax->datum #'cls.inherit-externals)))
(define this%-inherit-field-names
(list->set (syntax->datum #'cls.inherit-field-externals)))
(define this%-private-names (define this%-private-names
(list->set (syntax->datum #'cls.private-names))) (list->set (syntax->datum #'cls.private-names)))
(define this%-private-fields (define this%-private-fields
@ -249,6 +257,7 @@
#'cls.public-internals #'cls.public-internals
#'cls.override-internals #'cls.override-internals
#'cls.inherit-internals #'cls.inherit-internals
#'cls.inherit-field-internals
#'cls.pubment-internals #'cls.pubment-internals
#'cls.augment-internals)))) #'cls.augment-internals))))
(define all-external (define all-external
@ -260,6 +269,7 @@
#'cls.public-externals #'cls.public-externals
#'cls.override-externals #'cls.override-externals
#'cls.inherit-externals #'cls.inherit-externals
#'cls.inherit-field-externals
#'cls.pubment-externals #'cls.pubment-externals
#'cls.augment-externals)))) #'cls.augment-externals))))
;; establish a mapping between internal and external names ;; establish a mapping between internal and external names
@ -308,10 +318,12 @@
(match-define (Instance: (Class: _ inits fields methods augments)) (match-define (Instance: (Class: _ inits fields methods augments))
self-type) self-type)
;; trawl the body for the local name table ;; trawl the body for the local name table
(define locals (trawl-for-property #'cls.make-methods 'tr:class:local-table)) (define locals
(trawl-for-property #'cls.make-methods 'tr:class:local-table))
(define-values (local-method-table local-private-table local-field-table (define-values (local-method-table local-private-table local-field-table
local-private-field-table local-init-table local-private-field-table local-init-table
local-inherit-table local-super-table local-inherit-table local-inherit-field-table
local-super-table
local-augment-table local-inner-table) local-augment-table local-inner-table)
(construct-local-mapping-tables (car locals))) (construct-local-mapping-tables (car locals)))
;; types for private elements ;; types for private elements
@ -337,9 +349,12 @@
;; omit init-fields here since they don't have ;; omit init-fields here since they don't have
;; init accessors, only field accessors ;; init accessors, only field accessors
(list->set (syntax->datum #'cls.init-internals)) (list->set (syntax->datum #'cls.init-internals))
local-inherit-table local-super-table local-inherit-table
super-methods local-inherit-field-table
local-super-table
super-methods super-fields
this%-inherit-internals this%-inherit-internals
this%-inherit-field-internals
this%-override-internals this%-override-internals
local-augment-table local-inner-table local-augment-table local-inner-table
augments super-augments augments super-augments
@ -380,7 +395,7 @@
expected expected
this%-init-names this%-field-names this%-init-names this%-field-names
this%-public-names this%-override-names this%-public-names this%-override-names
this%-inherit-names this%-inherit-names this%-inherit-field-names
this%-pubment-names this%-augment-names this%-pubment-names this%-augment-names
(set-union optional-external optional-super) (set-union optional-external optional-super)
remaining-super-inits super-field-names remaining-super-inits super-field-names
@ -397,6 +412,7 @@
expected this%-init-names this%-field-names expected this%-init-names this%-field-names
this%-public-names this%-override-names this%-public-names this%-override-names
this%-inherit-names this%-inherit-names
this%-inherit-field-names
this%-pubment-names this%-augment-names this%-pubment-names this%-augment-names
optional-external optional-external
remaining-super-inits super-field-names remaining-super-inits super-field-names
@ -434,6 +450,8 @@
(check-exists (set-union super-method-names super-augment-names) (check-exists (set-union super-method-names super-augment-names)
this%-inherit-names this%-inherit-names
"inherited method") "inherited method")
(check-exists super-field-names this%-inherit-field-names
"inherited field")
(check-absent super-field-names this%-field-names "public field") (check-absent super-field-names this%-field-names "public field")
(check-absent super-method-names this%-public-names "public method") (check-absent super-method-names this%-public-names "public method")
(check-absent super-augment-names this%-pubment-names (check-absent super-augment-names this%-pubment-names
@ -475,9 +493,12 @@
local-private-field-table local-private-field-table
private-field-types private-field-names private-field-types private-field-names
local-init-table inits init-names local-init-table inits init-names
local-inherit-table local-super-table local-inherit-table
super-types local-inherit-field-table
inherit-names override-names local-super-table
super-types super-fields
inherit-names inherit-field-names
override-names
local-augment-table local-inner-table local-augment-table local-inner-table
augments super-augments augments super-augments
pubment-names augment-names pubment-names augment-names
@ -498,6 +519,12 @@
(map car localized-private-field-pairs)) (map car localized-private-field-pairs))
(define localized-private-field-set-names (define localized-private-field-set-names
(map cadr localized-private-field-pairs)) (map cadr localized-private-field-pairs))
(define localized-inherit-field-pairs
(localize local-inherit-field-table inherit-field-names))
(define localized-inherit-field-get-names
(map car localized-inherit-field-pairs))
(define localized-inherit-field-set-names
(map cadr localized-inherit-field-pairs))
(define localized-inherit-names (localize local-inherit-table inherit-names)) (define localized-inherit-names (localize local-inherit-table inherit-names))
(define localized-private-methods (define localized-private-methods
(localize local-private-table private-methods)) (localize local-private-table private-methods))
@ -559,6 +586,8 @@
(define-values (private-field-get-types private-field-set-types) (define-values (private-field-get-types private-field-set-types)
(make-field-types private-field-names private-field-types (make-field-types private-field-names private-field-types
#:private? #t)) #:private? #t))
(define-values (inherit-field-get-types inherit-field-set-types)
(make-field-types inherit-field-names super-fields))
;; types for privates and super calls ;; types for privates and super calls
(define (make-private-like-types names type-map) (define (make-private-like-types names type-map)
@ -589,6 +618,8 @@
localized-private-field-get-names localized-private-field-get-names
localized-private-field-set-names localized-private-field-set-names
localized-inherit-names localized-inherit-names
localized-inherit-field-get-names
localized-inherit-field-set-names
localized-override-names localized-override-names
localized-pubment-names localized-pubment-names
localized-augment-names localized-augment-names
@ -596,7 +627,10 @@
(define all-types (append method-types private-method-types (define all-types (append method-types private-method-types
field-get-types field-set-types field-get-types field-set-types
private-field-get-types private-field-set-types private-field-get-types private-field-set-types
inherit-types super-call-types inherit-types
inherit-field-get-types
inherit-field-set-types
super-call-types
pubment-types augment-types inner-types)) pubment-types augment-types inner-types))
(values all-names all-types (values all-names all-types
;; FIXME: consider removing method names and types ;; FIXME: consider removing method names and types
@ -794,6 +828,14 @@
(let-values (((_) _)) (let-values (((_) _))
(let-values (((_) _)) (#%plain-app local-private-set:id _ _)))) (let-values (((_) _)) (#%plain-app local-private-set:id _ _))))
...)] ...)]
[(inherit-field:id ...)
(#%plain-app
values
(#%plain-lambda ()
(let-values (((_) _)) (#%plain-app local-inherit-get:id _))
(let-values (((_) _))
(let-values (((_) _)) (#%plain-app local-inherit-set:id _ _))))
...)]
[(init:id ...) [(init:id ...)
(#%plain-app values (#%plain-lambda () local-init:id) ...)] (#%plain-app values (#%plain-lambda () local-init:id) ...)]
[(inherit:id ...) [(inherit:id ...)
@ -841,6 +883,10 @@
(map cons (map cons
(syntax->datum #'(inherit ...)) (syntax->datum #'(inherit ...))
(syntax->list #'(local-inherit ...))) (syntax->list #'(local-inherit ...)))
(map list
(syntax->datum #'(inherit-field ...))
(syntax->list #'(local-inherit-get ...))
(syntax->list #'(local-inherit-set ...)))
(map cons (map cons
(syntax->datum #'(override ...)) (syntax->datum #'(override ...))
(syntax->list #'(local-super ...))) (syntax->list #'(local-super ...)))

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

@ -563,6 +563,21 @@
(inherit [n m]) (inherit [n m])
(n 5))) (n 5)))
;; test inherit field
(check-ok
(class (class object% (super-new)
(field [x : Integer 0]))
(super-new)
(inherit-field x)))
;; test internal name with inherit-field
(check-ok
(class (class object% (super-new)
(field [x : Integer 0]))
(super-new)
(inherit-field [y x])
(set! y 1)))
;; fails, missing super method for inherit ;; fails, missing super method for inherit
(check-err (check-err
(class (class object% (super-new)) (super-new) (inherit z))) (class (class object% (super-new)) (super-new) (inherit z)))