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

Add infrastructure for private methods

Browse Source 
They don't actually work yet, because I don't yet know
how to assign them types for when they're called locally.
Probably requires the two pass approach for locals.

original commit: 709f3c66960fc08b77a7978c7c64ddb3e27b4c45
This commit is contained in:
Asumu Takikawa 2013-05-18 17:58:18 -04:00
parent d1ae0dc0e9
commit 2ee160cc8c
2 changed files with 23 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -239,7 +239,8 @@
(init-field #,@(dict-ref name-dict #'init-field '()))
(field #,@(dict-ref name-dict #'field '()))
(public #,@(dict-ref name-dict #'public '()))
(override #,@(dict-ref name-dict #'override '()))))
(override #,@(dict-ref name-dict #'override '()))
(private #,@(dict-ref name-dict #'private '()))))
(class #,annotated-super
#,@(map clause-stx clauses)
#,@(map non-clause-stx annotated-methods)
@ -269,7 +270,8 @@
[(define-values (id) . rst)
#:when (memf (λ (n) (free-identifier=? #'id n))
(append (dict-ref name-dict #'public '())
(dict-ref name-dict #'override '())))
(dict-ref name-dict #'override '())
(dict-ref name-dict #'private '())))
(values (cons (non-clause (syntax-property stx
'tr:class:method
(syntax-e #'id)))
@ -293,6 +295,7 @@
(define method-names
(append (dict-ref name-dict #'public '())
(dict-ref name-dict #'override '())))
(define private-names (dict-ref name-dict #'private '()))
(define field-names
(append (dict-ref name-dict #'field '())
(dict-ref name-dict #'init-field '())))
@ -300,6 +303,9 @@
#`(let-values ([(#,@method-names)
(values #,@(map (λ (stx) #`(λ () (#,stx)))
method-names))]
[(#,@private-names)
(values #,@(map (λ (stx) #`(λ () (#,stx)))
private-names))]
[(#,@field-names)
(values #,@(map (λ (stx) #`(λ () #,stx (set! #,stx 0)))
field-names))])

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

@ -48,7 +48,8 @@
(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:override)
c:init c:init-field c:field c:public c:override
c:private)
;; 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
@ -64,7 +65,8 @@
(c:init-field internal-init-field-names ...)
(c:field internal-field-names ...)
(c:public internal-public-names ...)
(c:override internal-override-names ...)))
(c:override internal-override-names ...)
(c:private internal-private-names ...)))
(#%plain-app values))))
(let-values (((superclass) superclass-expr)
((interfaces) interface-expr))
@ -108,6 +110,8 @@
(list->set (syntax->datum #'(internal-public-names ...))))
(define this%-override-names
(list->set (syntax->datum #'(internal-override-names ...))))
(define this%-private-names
(list->set (syntax->datum #'(internal-private-names ...))))
(define this%-method-names
(set-union this%-public-names this%-override-names))
;; Use the internal class: information to check whether clauses
@ -139,7 +143,7 @@
|#
;; trawl the body for the local name table
(define locals (trawl-for-property #'body 'tr:class:local-table))
(define-values (local-method-table local-field-table)
(define-values (local-method-table local-private-table local-field-table)
(construct-local-mapping-tables (car locals)))
;; find the `super-new` call (or error if missing)
(define super-new-stx (trawl-for-property #'body 'tr:class:super-new))
@ -220,6 +224,11 @@
(#%plain-lambda ()
(#%plain-app (#%plain-app local-method:id _) _))
...)]
[(private:id ...)
(#%plain-app
values
(#%plain-lambda () (#%plain-app local-private:id _))
...)]
[(field:id ...)
(#%plain-app
values
@ -232,6 +241,9 @@
(values (map cons
(syntax->datum #'(method ...))
(syntax->list #'(local-method ...)))
(map cons
(syntax->datum #'(private ...))
(syntax->list #'(local-private ...)))
(map list
(syntax->datum #'(field ...))
(syntax->list #'(local-field-get ...))