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

Support private fields

Browse Source
This commit is contained in:
Asumu Takikawa 2013-05-24 10:54:15 -04:00
parent 4559981212
commit bbd5d97a23
3 changed files with 122 additions and 26 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -25,7 +25,8 @@
class: class:
;; for use in ~literal clauses ;; for use in ~literal clauses
class:-internal class:-internal
optional-init) optional-init
private-field)
;; give it a binding, but it shouldn't be used directly ;; give it a binding, but it shouldn't be used directly
(define-syntax (class:-internal stx) (define-syntax (class:-internal stx)
@ -34,6 +35,9 @@
(define-syntax (optional-init stx) (define-syntax (optional-init stx)
(raise-syntax-error "should only be used internally")) (raise-syntax-error "should only be used internally"))
(define-syntax (private-field stx)
(raise-syntax-error "should only be used internally"))
(begin-for-syntax (begin-for-syntax
(module+ test (require rackunit)) (module+ test (require rackunit))
@ -239,7 +243,7 @@
clause? clause?
non-clause?)) non-clause?))
(define name-dict (extract-names clauses)) (define name-dict (extract-names clauses))
(define-values (annotated-methods other-top-level) (define-values (annotated-methods other-top-level private-fields)
(process-class-contents others name-dict)) (process-class-contents others name-dict))
(define annotated-super (define annotated-super
(syntax-property #'super 'tr:class:super #t)) (syntax-property #'super 'tr:class:super #t))
@ -258,6 +262,7 @@
(public #,@(dict-ref name-dict #'public '())) (public #,@(dict-ref name-dict #'public '()))
(override #,@(dict-ref name-dict #'override '())) (override #,@(dict-ref name-dict #'override '()))
(private #,@(dict-ref name-dict #'private '())) (private #,@(dict-ref name-dict #'private '()))
(private-field #,@private-fields)
(inherit #,@(dict-ref name-dict #'inherit '())))) (inherit #,@(dict-ref name-dict #'inherit '()))))
(class #,annotated-super (class #,annotated-super
#,@(map clause-stx clauses) #,@(map clause-stx clauses)
@ -265,18 +270,19 @@
#,(syntax-property #,(syntax-property
#`(begin #,@(map non-clause-stx other-top-level)) #`(begin #,@(map non-clause-stx other-top-level))
'tr:class:top-level #t) 'tr:class:top-level #t)
#,(make-locals-table name-dict))) #,(make-locals-table name-dict private-fields)))
'tr:class #t) 'tr:class #t)
'typechecker:ignore #t)])])) 'typechecker:ignore #t)])]))
(begin-for-syntax (begin-for-syntax
;; process-class-contents : Listof<Syntax> Dict<Id, Listof<Id>> ;; process-class-contents : Listof<Syntax> Dict<Id, Listof<Id>>
;; -> Listof<Syntax> Listof<Syntax> ;; -> Listof<Syntax> Listof<Syntax> Listof<Syntax>
;; Process methods and other top-level expressions and definitions ;; Process methods and other top-level expressions and definitions
;; that aren't class clauses like `init` or `public` ;; that aren't class clauses like `init` or `public`
(define (process-class-contents contents name-dict) (define (process-class-contents contents name-dict)
(for/fold ([methods '()] (for/fold ([methods '()]
[rest-top '()]) [rest-top '()]
[private-fields '()])
([content contents]) ([content contents])
(define stx (non-clause-stx content)) (define stx (non-clause-stx content))
(syntax-parse stx (syntax-parse stx
@ -293,13 +299,21 @@
'tr:class:method 'tr:class:method
(syntax-e #'id))) (syntax-e #'id)))
methods) methods)
rest-top)] rest-top private-fields)]
;; private field definition
[(define-values (id ...) . rst)
(values methods
(append rest-top (list content))
(append (syntax->list #'(id ...))
private-fields))]
;; Identify super-new for the benefit of the type checker ;; Identify super-new for the benefit of the type checker
[(super-new [init-id init-expr] ...) [(super-new [init-id init-expr] ...)
(define new-non-clause (define new-non-clause
(non-clause (syntax-property stx 'tr:class:super-new #t))) (non-clause (syntax-property stx 'tr:class:super-new #t)))
(values methods (append rest-top (list new-non-clause)))] (values methods (append rest-top (list new-non-clause))
[_ (values methods (append rest-top (list content)))]))) private-fields)]
[_ (values methods (append rest-top (list content))
private-fields)])))
;; get-optional-inits : Listof<Clause> -> Listof<Id> ;; get-optional-inits : Listof<Clause> -> Listof<Id>
;; Get a list of the internal names of mandatory inits ;; Get a list of the internal names of mandatory inits
@ -327,7 +341,7 @@
;; The identifiers inside the lambdas below will expand via ;; The identifiers inside the lambdas below will expand via
;; set!-transformers to the appropriate accessors, which lets ;; set!-transformers to the appropriate accessors, which lets
;; us figure out the accessor identifiers. ;; us figure out the accessor identifiers.
(define (make-locals-table name-dict) (define (make-locals-table name-dict private-field-names)
(define public-names (stx-map stx-car (dict-ref name-dict #'public '()))) (define public-names (stx-map stx-car (dict-ref name-dict #'public '())))
(define override-names (define override-names
(stx-map stx-car (dict-ref name-dict #'override '()))) (stx-map stx-car (dict-ref name-dict #'override '())))
@ -349,6 +363,9 @@
[(#,@field-names) [(#,@field-names)
(values #,@(map (λ (stx) #`(λ () #,stx (set! #,stx 0))) (values #,@(map (λ (stx) #`(λ () #,stx (set! #,stx 0)))
field-names))] field-names))]
[(#,@private-field-names)
(values #,@(map (λ (stx) #`(λ () #,stx (set! #,stx 0)))
private-field-names))]
[(#,@init-names) [(#,@init-names)
(values #,@(map (λ (stx) #`(λ () #,stx)) (values #,@(map (λ (stx) #`(λ () #,stx))
init-names))] init-names))]

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

@ -35,7 +35,7 @@
(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) c:public c:override c:private c:inherit private-field)
(pattern (begin (quote-syntax (pattern (begin (quote-syntax
(class:-internal (class:-internal
(c:init init-names:name-pair ...) (c:init init-names:name-pair ...)
@ -45,6 +45,7 @@
(c:public public-names:name-pair ...) (c:public public-names:name-pair ...)
(c:override override-names:name-pair ...) (c:override override-names:name-pair ...)
(c:private privates:id ...) (c:private privates:id ...)
(private-field private-fields:id ...)
(c:inherit inherit-names:name-pair ...))) (c:inherit inherit-names:name-pair ...)))
(#%plain-app values)) (#%plain-app values))
#:with init-internals #'(init-names.internal ...) #:with init-internals #'(init-names.internal ...)
@ -60,7 +61,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 private-names #'(privates ...))) #:with private-names #'(privates ...)
#:with private-field-names #'(private-fields ...)))
(define-syntax-class initializer-body (define-syntax-class initializer-body
#:literals (letrec-syntaxes+values) #:literals (letrec-syntaxes+values)
@ -117,7 +119,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
private-names private-names private-field-names
make-methods make-methods
initializer-body initializer-body
initializer-self-id initializer-self-id
@ -208,6 +210,8 @@
(list->set (syntax->datum #'cls.inherit-externals))) (list->set (syntax->datum #'cls.inherit-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
(list->set (syntax->datum #'cls.private-field-names)))
(define this%-method-names (define this%-method-names
(set-union this%-public-names this%-override-names)) (set-union this%-public-names this%-override-names))
(define all-internal (define all-internal
@ -274,13 +278,18 @@
;; 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-init-table local-inherit-table local-super-table) local-private-field-table local-init-table
local-inherit-table local-super-table)
(construct-local-mapping-tables (car locals))) (construct-local-mapping-tables (car locals)))
;; types for private elements ;; types for private elements
(define private-method-types (define private-method-types
(for/hash ([(name type) (in-dict internals-table)] (for/hash ([(name type) (in-dict internals-table)]
#:when (set-member? this%-private-names name)) #:when (set-member? this%-private-names name))
(values name type))) (values name type)))
(define private-field-types
(for/hash ([(name type) (in-dict internals-table)]
#:when (set-member? this%-private-fields name))
(values name (list type))))
;; start type-checking elements in the body ;; start type-checking elements in the body
(define-values (lexical-names lexical-types (define-values (lexical-names lexical-types
lexical-names/top-level lexical-types/top-level) lexical-names/top-level lexical-types/top-level)
@ -289,6 +298,8 @@
this%-method-internals this%-method-internals
local-field-table fields local-field-table fields
this%-field-internals this%-field-internals
local-private-field-table private-field-types
this%-private-fields
local-init-table inits local-init-table inits
;; 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
@ -393,6 +404,8 @@
(define (local-tables->lexical-env internal-external-mapping (define (local-tables->lexical-env internal-external-mapping
local-method-table methods method-names local-method-table methods method-names
local-field-table fields field-names local-field-table fields field-names
local-private-field-table
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 local-super-table
super-types super-types
@ -408,6 +421,12 @@
(define localized-field-pairs (localize local-field-table field-names)) (define localized-field-pairs (localize local-field-table field-names))
(define localized-field-get-names (map car localized-field-pairs)) (define localized-field-get-names (map car localized-field-pairs))
(define localized-field-set-names (map cadr localized-field-pairs)) (define localized-field-set-names (map cadr localized-field-pairs))
(define localized-private-field-pairs
(localize local-private-field-table private-field-names))
(define localized-private-field-get-names
(map car localized-private-field-pairs))
(define localized-private-field-set-names
(map cadr localized-private-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))
@ -429,19 +448,26 @@
(define method-types (make-method-types method-names methods)) (define method-types (make-method-types method-names methods))
(define inherit-types (make-method-types inherit-names super-types)) (define inherit-types (make-method-types inherit-names super-types))
(define field-get-types ;; construct field accessor types
(for/list ([f (in-set field-names)]) (define (make-field-types field-names type-map #:private? [private? #f])
(define external (dict-ref internal-external-mapping f)) (for/lists (_1 _2) ([f (in-set field-names)])
(define maybe-type (dict-ref fields external #f)) (define external
(->* (list (make-Univ)) (or (and maybe-type (car maybe-type)) (if private?
(make-Univ))))) f
(define field-set-types (dict-ref internal-external-mapping f)))
(for/list ([f (in-set field-names)]) (define maybe-type (dict-ref type-map external #f))
(define external (dict-ref internal-external-mapping f)) (values
(define maybe-type (dict-ref fields external #f)) (->* (list (make-Univ)) (or (and maybe-type (car maybe-type))
(->* (list (make-Univ) (or (and maybe-type (car maybe-type)) (make-Univ)))
-Bottom)) (->* (list (make-Univ) (or (and maybe-type (car maybe-type))
-Void))) -Bottom))
-Void))))
(define-values (field-get-types field-set-types)
(make-field-types field-names fields))
(define-values (private-field-get-types private-field-set-types)
(make-field-types private-field-names private-field-types
#:private? #t))
;; 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)
@ -465,10 +491,13 @@
localized-private-methods localized-private-methods
localized-field-get-names localized-field-get-names
localized-field-set-names localized-field-set-names
localized-private-field-get-names
localized-private-field-set-names
localized-inherit-names localized-inherit-names
localized-override-names)) localized-override-names))
(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
inherit-types super-call-types)) inherit-types super-call-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
@ -628,6 +657,14 @@
(let-values (((_) _)) (let-values (((_) _))
(let-values (((_) _)) (#%plain-app local-field-set:id _ _)))) (let-values (((_) _)) (#%plain-app local-field-set:id _ _))))
...)] ...)]
[(private-field:id ...)
(#%plain-app
values
(#%plain-lambda ()
(let-values (((_) _)) (#%plain-app local-private-get:id _))
(let-values (((_) _))
(let-values (((_) _)) (#%plain-app local-private-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 ...)
@ -656,6 +693,10 @@
(syntax->datum #'(field ...)) (syntax->datum #'(field ...))
(syntax->list #'(local-field-get ...)) (syntax->list #'(local-field-get ...))
(syntax->list #'(local-field-set ...))) (syntax->list #'(local-field-set ...)))
(map list
(syntax->datum #'(private-field ...))
(syntax->list #'(local-private-get ...))
(syntax->list #'(local-private-set ...)))
(map cons (map cons
(syntax->datum #'(init ...)) (syntax->datum #'(init ...))
(syntax->list #'(local-init ...))) (syntax->list #'(local-init ...)))

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

@ -382,6 +382,44 @@
(field [f "foo"]) (field [f "foo"])
(set! f 5)))) (set! f 5))))
;; test private field
(check-ok
(class: object%
(super-new)
(: x Integer)
(define x 5)
(set! x 8)
(+ x 1))
(: d% (Class (field [y String])))
(define d%
(class: object%
(super-new)
(: x Integer)
(define x 5)
(: y String)
(field [y "foo"]))))
;; fails, bad private field set!
(check-err
(class: object%
(super-new)
(: x Integer)
(define x 5)
(set! x "foo")))
;; fails, bad private field default
(check-err
(class: object%
(super-new)
(: x Integer)
(define x "foo")))
;; fails, private field needs type annotation
(check-err
(class: object%
(super-new)
(define x "foo")))
;; test private method ;; test private method
(check-ok (check-ok
(class: object% (super-new) (class: object% (super-new)