Make internal/external names work
original commit: f895e3156f26d01a5c62c18d675514204440f9ff
This commit is contained in:
Asumu Takikawa
parent
21b9774043
commit
f4c8fd57e0
|
|
@ -70,11 +70,16 @@
|
|||
(quote-syntax inspect)))))
|
||||
|
||||
(begin-for-syntax
|
||||
;; A Clause is a (clause Syntax Id Listof<Id>)
|
||||
;; A Clause is a (clause Syntax Id Listof<Syntax>)
|
||||
;;
|
||||
;; interp. a class clause such as init or field.
|
||||
(struct clause (stx type ids))
|
||||
|
||||
;; An InitClause is a (init-clause Syntax Id Listof<Syntax> Boolean)
|
||||
;;
|
||||
;; interp. an init class clause
|
||||
(struct init-clause clause (optional?))
|
||||
|
||||
;; A NonClause is a (non-clause Syntax)
|
||||
;;
|
||||
;; interp. a top-level class expression that is not one of the special
|
||||
|
|
@ -82,31 +87,29 @@
|
|||
(struct non-clause (stx))
|
||||
|
||||
(define-syntax-class init-decl
|
||||
(pattern id
|
||||
#:with internal-id #'id
|
||||
#:with external-id #'id)
|
||||
(pattern id:id
|
||||
#:attr optional? #f
|
||||
#:with ids #'(id id))
|
||||
(pattern (ren:renamed)
|
||||
#:with internal-id #'ren.internal-id
|
||||
#:with external-id #'ren.external-id)
|
||||
#:attr optional? #f
|
||||
#:with ids #'ren.ids)
|
||||
(pattern (mren:maybe-renamed default-value:expr)
|
||||
#:with internal-id #'mren.internal-id
|
||||
#:with external-id #'mren.external-id))
|
||||
#:attr optional? #t
|
||||
#:with ids #'mren.ids))
|
||||
|
||||
(define-syntax-class field-decl
|
||||
(pattern (mren:maybe-renamed default-value:expr)
|
||||
#:with internal-id #'mren.internal-id
|
||||
#:with external-id #'mren.external-id))
|
||||
#:with ids #'mren.ids))
|
||||
|
||||
(define-syntax-class renamed
|
||||
(pattern (internal-id:id external-id:id)))
|
||||
(pattern (internal-id:id external-id:id)
|
||||
#:with ids #'(internal-id external-id)))
|
||||
|
||||
(define-syntax-class maybe-renamed
|
||||
(pattern id
|
||||
#:with internal-id #'id
|
||||
#:with external-id #'id)
|
||||
(pattern id:id
|
||||
#:with ids #'(id id))
|
||||
(pattern ren:renamed
|
||||
#:with internal-id #'ren.internal-id
|
||||
#:with external-id #'ren.external-id))
|
||||
#:with ids #'ren.ids))
|
||||
|
||||
(define-syntax-class class-clause
|
||||
(pattern (~and ((~and clause-name (~or (~literal init)
|
||||
|
|
@ -117,11 +120,12 @@
|
|||
;; make this an attribute instead to represent
|
||||
;; internal and external names
|
||||
#:attr data
|
||||
(clause #'form #'clause-name
|
||||
(stx->list #'(names.external-id ...))))
|
||||
(init-clause #'form #'clause-name
|
||||
(stx->list #'(names.ids ...))
|
||||
(attribute names.optional?)))
|
||||
(pattern (~and ((~literal field) names:field-decl ...) form)
|
||||
#:attr data (clause #'form #'field
|
||||
(stx->list #'(names.external-id ...))))
|
||||
(stx->list #'(names.ids ...))))
|
||||
(pattern (~and ((~and clause-name (~or (~literal inherit-field)
|
||||
(~literal public)
|
||||
(~literal pubment)
|
||||
|
|
@ -139,7 +143,7 @@
|
|||
form)
|
||||
#:attr data
|
||||
(clause #'form #'clause-name
|
||||
(stx->list #'(names.external-id ...))))
|
||||
(stx->list #'(names.ids ...))))
|
||||
(pattern (~and ((~and clause-name (~or (~literal private)
|
||||
(~literal abstract)))
|
||||
names:id ...)
|
||||
|
|
@ -176,11 +180,13 @@
|
|||
[_ stx]))
|
||||
|
||||
(module+ test
|
||||
;; equal? check but considers identifier equality
|
||||
;; equal? check but considers stx pair equality
|
||||
(define (equal?/id x y)
|
||||
(if (and (identifier? x) (identifier? y))
|
||||
(free-identifier=? x y)
|
||||
(equal?/recur x y equal?/id)))
|
||||
(if (and (syntax? x) (syntax? y))
|
||||
(and (free-identifier=? (stx-car x) (stx-car y))
|
||||
(free-identifier=? (stx-car (stx-cdr x))
|
||||
(stx-car (stx-cdr y))))
|
||||
(equal?/recur x y equal?/id)))
|
||||
|
||||
;; utility macro for checking if a syntax matches a
|
||||
;; given syntax class
|
||||
|
|
@ -200,11 +206,15 @@
|
|||
(check-true (syntax-parses? #'(public f g h) class-clause))
|
||||
(check-true (syntax-parses? #'(public f) class-clause-or-other))
|
||||
(check-equal?/id
|
||||
(extract-names (list (clause #'(init x y z) #'init (list #'x #'y #'z))
|
||||
(clause #'(public f g h) #'public (list #'f #'g #'h))))
|
||||
(extract-names (list (clause #'(init x y z)
|
||||
#'init
|
||||
(list #'(x x) #'(y y) #'(z z)))
|
||||
(clause #'(public f g h)
|
||||
#'public
|
||||
(list #'(f f) #'(g g) #'(h h)))))
|
||||
(make-immutable-free-id-table
|
||||
(hash #'public (list #'f #'g #'h)
|
||||
#'init (list #'x #'y #'z))))))
|
||||
(hash #'public (list #'(f f) #'(g g) #'(h h))
|
||||
#'init (list #'(x x) #'(y y) #'(z z)))))))
|
||||
|
||||
(define-syntax (class: stx)
|
||||
(syntax-parse stx
|
||||
|
|
@ -269,8 +279,8 @@
|
|||
;; FIXME: this needs to track privates, augments, etc.
|
||||
[(define-values (id) . rst)
|
||||
#:when (memf (λ (n) (free-identifier=? #'id n))
|
||||
(append (dict-ref name-dict #'public '())
|
||||
(dict-ref name-dict #'override '())
|
||||
(append (stx-map stx-car (dict-ref name-dict #'public '()))
|
||||
(stx-map stx-car (dict-ref name-dict #'override '()))
|
||||
(dict-ref name-dict #'private '())))
|
||||
(values (cons (non-clause (syntax-property stx
|
||||
'tr:class:method
|
||||
|
|
@ -293,12 +303,12 @@
|
|||
;; us figure out the accessor identifiers.
|
||||
(define (make-locals-table name-dict)
|
||||
(define method-names
|
||||
(append (dict-ref name-dict #'public '())
|
||||
(dict-ref name-dict #'override '())))
|
||||
(append (stx-map stx-car (dict-ref name-dict #'public '()))
|
||||
(stx-map stx-car (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 '())))
|
||||
(append (stx-map stx-car (dict-ref name-dict #'field '()))
|
||||
(stx-map stx-car (dict-ref name-dict #'init-field '()))))
|
||||
(syntax-property
|
||||
#`(let-values ([(#,@method-names)
|
||||
(values #,@(map (λ (stx) #`(λ () (#,stx)))
|
||||
|
|
|
|||
|
|
@ -28,6 +28,34 @@
|
|||
(import tc-if^ tc-lambda^ tc-app^ tc-let^ tc-expr^)
|
||||
(export check-class^)
|
||||
|
||||
;; Syntax classes for use in functions below
|
||||
(define-syntax-class name-pair
|
||||
(pattern (internal:id external:id)))
|
||||
|
||||
(define-syntax-class internal-class-data
|
||||
#:literals (#%plain-app quote-syntax class:-internal begin
|
||||
values c:init c:init-field c:field
|
||||
c:public c:override c:private)
|
||||
(pattern (begin (quote-syntax
|
||||
(class:-internal
|
||||
(c:init init-names:name-pair ...)
|
||||
(c:init-field init-field-names:name-pair ...)
|
||||
(c:field field-names:name-pair ...)
|
||||
(c:public public-names:name-pair ...)
|
||||
(c:override override-names:name-pair ...)
|
||||
(c:private private-names:id ...)))
|
||||
(#%plain-app values))
|
||||
#:with init-internals #'(init-names.internal ...)
|
||||
#:with init-externals #'(init-names.external ...)
|
||||
#:with init-field-internals #'(init-field-names.internal ...)
|
||||
#:with init-field-externals #'(init-field-names.external ...)
|
||||
#:with field-internals #'(field-names.internal ...)
|
||||
#:with field-externals #'(field-names.external ...)
|
||||
#:with public-internals #'(public-names.internal ...)
|
||||
#:with public-externals #'(public-names.external ...)
|
||||
#:with override-internals #'(override-names.internal ...)
|
||||
#:with override-externals #'(override-names.external ...)))
|
||||
|
||||
;; Syntax TCResults -> Type
|
||||
;; Type-check a class form by trawling its innards
|
||||
;;
|
||||
|
|
@ -48,10 +76,8 @@
|
|||
;; Do the actual type-checking
|
||||
(define (do-check form expected? self-class-type)
|
||||
(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:private)
|
||||
#:literals (let-values #%plain-lambda begin
|
||||
#%plain-app values letrec-syntaxes+values)
|
||||
;; 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
|
||||
|
|
@ -59,17 +85,7 @@
|
|||
(letrec-syntaxes+values ()
|
||||
((()
|
||||
;; residual class: data
|
||||
;; FIXME: put in syntax class
|
||||
(begin
|
||||
(quote-syntax
|
||||
(class:-internal
|
||||
(c:init internal-init-names ...)
|
||||
(c:init-field internal-init-field-names ...)
|
||||
(c:field internal-field-names ...)
|
||||
(c:public internal-public-names ...)
|
||||
(c:override internal-override-names ...)
|
||||
(c:private internal-private-names ...)))
|
||||
(#%plain-app values))))
|
||||
data:internal-class-data))
|
||||
(let-values (((superclass) superclass-expr)
|
||||
((interfaces) interface-expr))
|
||||
(?#%app compose-class
|
||||
|
|
@ -98,34 +114,66 @@
|
|||
(define super-init-names (list->set (dict-keys super-inits)))
|
||||
(define super-field-names (list->set (dict-keys super-fields)))
|
||||
(define super-method-names (list->set (dict-keys super-methods)))
|
||||
(define this%-init-internals
|
||||
(list->set (append (syntax->datum #'data.init-internals)
|
||||
(syntax->datum #'data.init-internals))))
|
||||
(define this%-public-internals
|
||||
(list->set (syntax->datum #'data.public-internals)))
|
||||
(define this%-override-internals
|
||||
(list->set (syntax->datum #'data.override-internals)))
|
||||
(define this%-method-internals
|
||||
(set-union this%-public-internals this%-override-internals))
|
||||
(define this%-field-internals
|
||||
(list->set (syntax->datum #'data.field-internals)))
|
||||
(define this%-init-names
|
||||
(list->set
|
||||
(append (syntax->datum #'(internal-init-names ...))
|
||||
(syntax->datum #'(internal-init-field-names ...)))))
|
||||
(append (syntax->datum #'data.init-externals)
|
||||
(syntax->datum #'data.init-field-externals))))
|
||||
(define this%-field-names
|
||||
(list->set
|
||||
(append (syntax->datum #'(internal-field-names ...))
|
||||
(syntax->datum #'(internal-init-field-names ...)))))
|
||||
(append (syntax->datum #'data.field-externals)
|
||||
(syntax->datum #'data.init-field-externals))))
|
||||
(define this%-public-names
|
||||
(list->set (syntax->datum #'(internal-public-names ...))))
|
||||
(list->set (syntax->datum #'data.public-externals)))
|
||||
(define this%-override-names
|
||||
(list->set (syntax->datum #'(internal-override-names ...))))
|
||||
(list->set (syntax->datum #'data.override-externals)))
|
||||
(define this%-private-names
|
||||
(list->set (syntax->datum #'(internal-private-names ...))))
|
||||
(list->set (syntax->datum #'(data.private-names ...))))
|
||||
(define this%-method-names
|
||||
(set-union this%-public-names this%-override-names))
|
||||
(define all-internal
|
||||
(apply append
|
||||
(map (λ (stx) (syntax->datum stx))
|
||||
(list #'data.init-internals
|
||||
#'data.init-field-internals
|
||||
#'data.field-internals
|
||||
#'data.public-internals
|
||||
#'data.override-internals))))
|
||||
(define all-external
|
||||
(apply append
|
||||
(map (λ (stx) (syntax->datum stx))
|
||||
(list #'data.init-externals
|
||||
#'data.init-field-externals
|
||||
#'data.field-externals
|
||||
#'data.public-externals
|
||||
#'data.override-externals))))
|
||||
;; establish a mapping between internal and external names
|
||||
(define internal-external-mapping
|
||||
(for/hash ([internal all-internal]
|
||||
[external all-external])
|
||||
(values internal external)))
|
||||
;; trawl the body for top-level expressions
|
||||
(define top-level-exprs (trawl-for-property #'body 'tr:class:top-level))
|
||||
(define internals-table
|
||||
(register-internals top-level-exprs #'(internal-public-names ...)))
|
||||
(define internals-table (register-internals top-level-exprs))
|
||||
;; Type for self in method calls
|
||||
(define self-type
|
||||
(if self-class-type
|
||||
(make-Instance self-class-type)
|
||||
(infer-self-type internals-table
|
||||
this%-init-names
|
||||
this%-field-names
|
||||
this%-public-names)))
|
||||
internal-external-mapping
|
||||
this%-init-internals
|
||||
this%-field-internals
|
||||
this%-public-internals)))
|
||||
(match-define (Instance: (Class: _ inits fields methods))
|
||||
self-type)
|
||||
;; Use the internal class: information to check whether clauses
|
||||
|
|
@ -161,8 +209,8 @@
|
|||
(construct-local-mapping-tables (car locals)))
|
||||
;; start type-checking elements in the body
|
||||
(define-values (lexical-names lexical-types)
|
||||
(local-tables->lexical-env local-method-table methods this%-method-names
|
||||
local-field-table fields this%-field-names
|
||||
(local-tables->lexical-env local-method-table methods this%-method-internals
|
||||
local-field-table fields this%-field-internals
|
||||
self-type))
|
||||
(with-lexical-env/extend lexical-names lexical-types
|
||||
(for ([stx top-level-exprs]
|
||||
|
|
@ -175,7 +223,7 @@
|
|||
(define meths (trawl-for-property #'body 'tr:class:method))
|
||||
(define checked-method-types
|
||||
(with-lexical-env/extend lexical-names lexical-types
|
||||
(check-methods meths methods self-type)))
|
||||
(check-methods internal-external-mapping meths methods self-type)))
|
||||
(if expected?
|
||||
self-class-type
|
||||
(merge-types self-type checked-method-types))]))
|
||||
|
|
@ -242,12 +290,15 @@
|
|||
localized-field-get-names localized-field-set-names)
|
||||
(append method-types field-get-types field-set-types)))
|
||||
|
||||
;; check-methods : Listof<Syntax> Dict Type -> Dict<Symbol, Type>
|
||||
;; check-methods : Listof<Syntax> Dict<Symbol, Symbol> Dict Type
|
||||
;; -> Dict<Symbol, Type>
|
||||
;; Type-check the methods inside of a class
|
||||
(define (check-methods meths methods self-type)
|
||||
(define (check-methods internal-external-mapping
|
||||
meths methods self-type)
|
||||
(for/list ([meth meths])
|
||||
(define method-name (syntax-property meth 'tr:class:method))
|
||||
(define maybe-expected (dict-ref methods method-name #f))
|
||||
(define external-name (dict-ref internal-external-mapping method-name))
|
||||
(define maybe-expected (dict-ref methods external-name #f))
|
||||
(cond [maybe-expected
|
||||
(define pre-method-type (car maybe-expected))
|
||||
(define method-type
|
||||
|
|
@ -255,8 +306,8 @@
|
|||
(define expected (ret method-type))
|
||||
(define annotated (annotate-method meth self-type method-type))
|
||||
(tc-expr/check annotated expected)
|
||||
(list method-name pre-method-type)]
|
||||
[else (list method-name
|
||||
(list external-name pre-method-type)]
|
||||
[else (list external-name
|
||||
(unfixup-method-type (tc-expr/t meth)))])))
|
||||
|
||||
;; Syntax -> Dict<Symbol, Id> Dict<Symbol, (List Symbol Symbol)>
|
||||
|
|
@ -350,7 +401,7 @@
|
|||
;; register-internals : Listof<Syntax> -> Dict<Symbol, Type>
|
||||
;; Find : annotations and register them
|
||||
;; TODO: support `define-type`?
|
||||
(define (register-internals stxs dummy)
|
||||
(define (register-internals stxs)
|
||||
(for/fold ([table '()])
|
||||
([stx stxs])
|
||||
(syntax-parse stx
|
||||
|
|
@ -365,19 +416,22 @@
|
|||
table)]
|
||||
[_ table])))
|
||||
|
||||
;; infer-self-type : Dict<Symbol, Type> Set<Symbol> * 3 -> Type
|
||||
;; infer-self-type : Dict<Symbol, Type> Dict<Symbol, Symbol>
|
||||
;; Set<Symbol> * 3 -> Type
|
||||
;; Construct a self object type based on the registered types
|
||||
;; from : inside the class body.
|
||||
(define (infer-self-type internals-table inits fields publics)
|
||||
(define (infer-self-type internals-table internal-external-mapping
|
||||
inits fields publics)
|
||||
(define (make-type-dict names [inits? #f])
|
||||
(for/fold ([type-dict '()])
|
||||
([name names])
|
||||
(define external (dict-ref internal-external-mapping name))
|
||||
(cond [(dict-ref internals-table name #f) =>
|
||||
(λ (type)
|
||||
(define entry
|
||||
;; FIXME: this should record the correct optional
|
||||
;; boolean based on internal macro data
|
||||
(if inits? (list name type #f) (list name type)))
|
||||
(if inits? (list external type #f) (list external type)))
|
||||
(cons entry type-dict))]
|
||||
[else type-dict])))
|
||||
(define init-types (make-type-dict inits #t))
|
||||
|
|
|
|||
|
|
@ -317,6 +317,70 @@
|
|||
(define/public (m y) 0)
|
||||
(+ "foo" 5))))
|
||||
|
||||
;; test different internal/external names
|
||||
(check-ok
|
||||
(define c% (class: object% (super-new)
|
||||
(public [m n])
|
||||
(define m (lambda () 0))))
|
||||
(send (new c%) n))
|
||||
|
||||
;; internal/external the same is ok
|
||||
(check-ok
|
||||
(define c% (class: object% (super-new)
|
||||
(public [m m])
|
||||
(define m (lambda () 0))))
|
||||
(send (new c%) m))
|
||||
|
||||
;; fails, internal name not accessible
|
||||
(check-err
|
||||
(define c% (class: object% (super-new)
|
||||
(public [m n])
|
||||
(define m (lambda () 0))))
|
||||
(send (new c%) m))
|
||||
|
||||
;; test internal/external with expected
|
||||
(check-ok
|
||||
(: c% (Class [n (-> Integer)]))
|
||||
(define c% (class: object% (super-new)
|
||||
(public [m n])
|
||||
(define m (lambda () 0))))
|
||||
(send (new c%) n))
|
||||
|
||||
;; test internal/external field
|
||||
(check-ok
|
||||
(define c% (class: object% (super-new)
|
||||
(: f Integer)
|
||||
(field ([f g] 0))))
|
||||
(get-field g (new c%)))
|
||||
|
||||
;; fail, internal name not accessible
|
||||
(check-err
|
||||
(define c% (class: object% (super-new)
|
||||
(: f Integer)
|
||||
(field ([f g] 0))))
|
||||
(get-field f (new c%)))
|
||||
|
||||
;; test internal/external init
|
||||
(check-ok
|
||||
(define c% (class: object% (super-new)
|
||||
(: i Integer)
|
||||
(init ([i j]))))
|
||||
(new c% [j 5]))
|
||||
|
||||
;; fails, internal name not accessible
|
||||
(check-err
|
||||
(define c% (class: object% (super-new)
|
||||
(: i Integer)
|
||||
(init ([i j]))))
|
||||
(new c% [i 5]))
|
||||
|
||||
;; test type-checking method with internal/external
|
||||
(check-err
|
||||
(: c% (Class [n (Integer -> Integer)]))
|
||||
(define c% (class: object% (super-new)
|
||||
(public [m n])
|
||||
(define m (lambda () 0)))))
|
||||
|
||||
;; test type-checking without expected class type
|
||||
(check-ok
|
||||
(define c% (class: object% (super-new)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user