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

Fix typed private class fields with functions

Browse Source 
A public method definition and a private field that contains
a function are hard to distinguish without traversing the entire
class body, which caused TR to fail to detect the private field
case. TR now uses more compile-time state to precisely
distinguish the cases.

Also fixes a related bug in which TR would incorrectly handle
multiple private fields defined with a single `define-values`.

Closes PR 14788

original commit: 670c8576851cb21e910778f913270a0752e7ede4
This commit is contained in:
Asumu Takikawa 2014-10-23 00:14:20 -04:00
parent 85bd67a8b0
commit 758d4a64b0
4 changed files with 122 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -63,12 +63,14 @@
;; TRClassInfo stores information in the class macro that lets the
;; TR class helper macros coordinate amongst each other.
;;
;; It is a (tr-class-info List<Clause> List<Identifier>)
;; It is a (tr-class-info List<Clause> List<Identifier> List<Identifier>)
;;
;; clauses - stores in reverse order all class clauses that appeared
;; in the class expression
;; private-fields - a list of private field names
(struct tr-class-info (clauses private-fields) #:mutable)
;; maybe-private - a list of field names that are not known to be method
;; definitions or a private field at the time of discovery
(struct tr-class-info (clauses private-fields maybe-private) #:mutable)
;; forms that are not allowed by Typed Racket yet
(define unsupported-forms
@ -128,8 +130,9 @@
(tr:class
(quasisyntax/loc stx
(untyped:class #,(tr:class:super-property #'super #t)
(define-syntax class-info (tr-class-info null null))
(define-syntax class-info (tr-class-info null null null))
(add-annotations class-info e) ...
(determine-private-fields class-info)
(make-locals-table class-info)
(make-class-name-table
class-info
@ -141,6 +144,7 @@
(syntax-parse stx
#:literal-sets (kernel-literals)
[(_ class-info:id class-exp)
(define info (syntax-local-value #'class-info))
(define expanded (local-expand #'class-exp (syntax-local-context) stop-forms))
(syntax-parse expanded
#:literal-sets (kernel-literals)
@ -150,7 +154,6 @@
(quasisyntax/loc #'class-exp
(begin (add-annotations class-info e) ...))]
[cls:class-clause
(define info (syntax-local-value #'class-info))
(define clause-data (attribute cls.data))
(match-define (struct clause (stx kind ids types)) clause-data)
;; to avoid macro taint issues
@ -171,17 +174,17 @@
;; mark it as something to type-check
[(define-values (id) body)
#:when (method-procedure? #'body)
(tr:class:method-property #'class-exp (syntax-e #'id))]
(set-tr-class-info-maybe-private!
info
(cons #'id (tr-class-info-maybe-private info)))
(tr:class:def-property #'class-exp #'id)]
;; private field definition
[(define-values (id ...) . rst)
(define info (syntax-local-value #'class-info))
(set-tr-class-info-private-fields!
info
(append (syntax->list #'(id ...))
(tr-class-info-private-fields info)))
;; set this property so that the initialization expression for
;; this field is counted as a top-level class expression
(tr:class:top-level-property #'class-exp #t)]
(tr:class:def-property #'class-exp #'(id ...))]
;; special : annotation for augment interface
[(: name:id type:expr #:augment augment-type:expr)
(quasisyntax/loc #'class-exp
@ -208,12 +211,37 @@
#t)]
[_ (tr:class:top-level-property #'class-exp #t)])]))
;; Some definitions in the class are not known to be private fields or
;; public method definitions until the whole class is processed. This
;; macro makes the decision at the end of the class.
(define-syntax (determine-private-fields stx)
(syntax-parse stx
[(_ class-info:id)
(match-define (and info (tr-class-info clauses private-fields maybe-ids))
(syntax-local-value #'class-info))
(define actual-private-fields
(for/fold ([actual-private-fields private-fields])
([cur-id (in-list maybe-ids)])
(define private-field?
(or ;; multiple define-values names are only legal for fields
(stx-pair? cur-id)
(for/and ([clause (in-list clauses)])
(define ids
(for/list ([id (in-list (clause-ids clause))])
(if (stx-pair? id) (stx-car id) id)))
(not (member cur-id ids free-identifier=?)))))
(if private-field?
(cons cur-id actual-private-fields)
actual-private-fields)))
(set-tr-class-info-private-fields! info actual-private-fields)
#'(void)]))
;; Construct a table in the expansion that lets TR know about the generated
;; identifiers that are used for methods, fields, and such
(define-syntax (make-locals-table stx)
(syntax-parse stx
[(_ class-info:id)
(match-define (tr-class-info clauses private-fields)
(match-define (tr-class-info clauses private-fields _)
(syntax-local-value #'class-info))
(do-make-locals-table (reverse clauses) private-fields)]))
@ -222,7 +250,7 @@
(define-syntax (make-class-name-table stx)
(syntax-parse stx
[(_ class-info:id (type-variable:id ...))
(match-define (tr-class-info clauses private-fields)
(match-define (tr-class-info clauses private-fields _)
(syntax-local-value #'class-info))
(do-make-class-name-table #'(type-variable ...)
(reverse clauses)

2
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/syntax-properties.rkt
View File

@ -75,6 +75,6 @@
(tr:class:local-table tr:class:local-table)
(tr:class:name-table tr:class:name-table)
(tr:class:clause-ids tr:class:clause-ids)
(tr:class:method tr:class:method)
(tr:class:def tr:class:def)
)

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

@ -347,8 +347,7 @@
;; the only kind of type annotation that is allowed to be duplicate
;; (i.e., m can have type Integer -> Integer and an augment type of
;; String -> String in the separate tables)
(define-values (super-new initializers
annotation-table augment-annotation-table
(define-values (super-new annotation-table augment-annotation-table
other-top-level-exprs)
(handle-top-levels top-level-exprs))
@ -402,6 +401,24 @@
local-augment-table local-inner-table)
(construct-local-mapping-tables (car locals)))
;; trawl the body and find methods and private field definitions
(define def-stxs
(trawl-for-property make-methods-stx tr:class:def-property))
;; FIXME: private field names should be stored as identifiers since
;; it's possible to have the same symbolic name for them
(define private-field-names (hash-ref parse-info 'private-fields))
(define-values (private-field-stxs method-stxs)
(for/fold ([private-field-stxs null]
[method-stxs null])
([def-stx (in-list def-stxs)])
(define name/names (tr:class:def-property def-stx))
(if (stx-pair? name/names)
(values (cons def-stx private-field-stxs) method-stxs)
(if ;; FIXME: see above on syntax-e
(memq (syntax-e name/names) private-field-names)
(values (cons def-stx private-field-stxs) method-stxs)
(values private-field-stxs (cons def-stx method-stxs))))))
;; types for private elements
(define private-method-types
(for/hash ([(name type) (in-dict annotation-table)]
@ -412,7 +429,7 @@
#:when (set-member? (hash-ref parse-info 'private-fields) name))
(hash-set! private-field-types name (list type)))
(synthesize-private-field-types initializers
(synthesize-private-field-types private-field-stxs
local-private-field-table
private-field-types)
@ -447,24 +464,21 @@
local-field-table
inits))
(do-timestamp "checked field initializers")
;; trawl the body and find methods and type-check them
(define meth-stxs
(trawl-for-property make-methods-stx tr:class:method-property))
(define checked-method-types
(with-lexical-env/extend lexical-names lexical-types
(check-methods (append (hash-ref parse-info 'pubment-names)
(hash-ref parse-info 'overridable-names))
internal-external-mapping meth-stxs
internal-external-mapping method-stxs
methods self-type)))
(do-timestamp "checked methods")
(define checked-augment-types
(with-lexical-env/extend lexical-names lexical-types
(check-methods (hash-ref parse-info 'augment-names)
internal-external-mapping meth-stxs
internal-external-mapping method-stxs
augments self-type)))
(do-timestamp "checked augments")
(with-lexical-env/extend lexical-names lexical-types
(check-private-methods meth-stxs (hash-ref parse-info 'private-names)
(check-private-methods method-stxs (hash-ref parse-info 'private-names)
private-method-types self-type))
(do-timestamp "checked privates")
(do-timestamp "finished methods")
@ -489,12 +503,11 @@
final-class-type)))
;; handle-top-levels : (Listof Syntax) ->
;; super-init-stxs Dict Dict Hash (Listof Syntax)
;; super-init-stxs Dict Hash (Listof Syntax)
;; Divide top level expressions into several categories, and put them
;; in appropriate data structures.
(define (handle-top-levels exprs)
(define super-new #f)
(define initializers (make-free-id-table))
(define annotations (make-hash))
(define augment-annotations (make-hash))
(define other-exprs
@ -503,19 +516,6 @@
(syntax-parse expr
#:literal-sets (kernel-literals)
#:literals (:-augment)
[(begin
(quote ((~datum declare-field-initialization) _))
(let-values ([(obj:id) self])
(let-values ([(field:id) initial-value])
(with-continuation-mark _ _
(#%plain-app setter:id obj2:id field2:id)))))
;; There should only be one initialization expression per field
;; since they are distinguished by a declaration.
(cond [(not (dict-has-key? initializers #'setter))
(free-id-table-set! initializers #'setter #'initial-value)]
[else
(int-err "more than one field initialization expression")])
other-exprs]
;; The second part of this pattern ensures that we find the actual
;; initialization call, rather than the '(declare-super-new) in
;; the expansion.
@ -546,7 +546,6 @@
#:more "must call `super-new' at the top-level of the class")
(set! super-new (super-init-stxs null null)))
(values super-new
initializers
annotations
augment-annotations
other-exprs))
@ -849,7 +848,7 @@
meths methods self-type)
(for/fold ([checked '()])
([meth meths])
(define method-name (tr:class:method-property meth))
(define method-name (syntax-e (tr:class:def-property meth)))
(define external-name (dict-ref internal-external-mapping method-name #f))
(define maybe-expected (and external-name (dict-ref methods external-name #f)))
(cond [(and maybe-expected
@ -887,7 +886,7 @@
;; Type-check private methods
(define (check-private-methods stxs names types self-type)
(for ([stx stxs])
(define method-name (tr:class:method-property stx))
(define method-name (syntax-e (tr:class:def-property stx)))
(define private? (set-member? names method-name))
(define annotation (dict-ref types method-name #f))
(cond [(and private? annotation)
@ -985,20 +984,46 @@
[else
(tc-expr/check init-val (ret init-type))])))
;; synthesize-private-field-types : IdTable Dict Hash -> Void
;; synthesize-private-field-types : Listof<Syntax> Dict Hash -> Void
;; Given top-level expressions in the class, synthesize types from
;; the initialization expressions for private fields.
(define (synthesize-private-field-types initializers locals types)
(for ([(name getter+setter) (in-dict locals)]
#:unless (hash-has-key? types name))
(match-define (list _ setter) getter+setter)
(define init-expr-stx (free-id-table-ref initializers setter #f))
(when init-expr-stx
(define type (tc-expr/t init-expr-stx))
;; FIXME: this always generalizes the private field
;; type, but it's better to only generalize if
;; the field is actually mutated.
(hash-set! types name (list (generalize type))))))
(define (synthesize-private-field-types stxs locals types)
(for ([stx (in-list stxs)])
(syntax-parse stx
#:literal-sets (kernel-literals)
[(begin
(quote ((~datum declare-field-initialization) _))
(let-values ([(obj:id) self])
(let-values ([(field:id) initial-value])
(with-continuation-mark
_ _ (#%plain-app setter:id obj2:id field2:id)))))
(define name-stx (tr:class:def-property stx))
(define name (if (stx-pair? name-stx)
(syntax-e (stx-car name-stx))
(syntax-e name-stx)))
;; don't synthesize if there's already a type annotation
(unless (hash-has-key? types name)
;; FIXME: this always generalizes the private field
;; type, but it's better to only generalize if
;; the field is actually mutated.
(hash-set! types name
(list (generalize (tc-expr/t #'initial-value)))))]
[(let-values ([(initial-value-name:id ...)
(#%plain-app _ initial-value ...)])
(begin
(quote ((~datum declare-field-initialization) _))
(let-values ([(obj:id) self])
(let-values ([(field:id) initial-value-name-2:id])
(with-continuation-mark
_ _ (#%plain-app setter:id obj2:id field2:id)))))
...
(#%plain-app _))
(define names (map syntax-e (syntax-e (tr:class:def-property stx))))
(for ([name (in-list names)]
[initial-value-stx (in-list (syntax->list #'(initial-value ...)))])
(unless (hash-has-key? types name)
(hash-set! types name
(list (generalize (tc-expr/t initial-value-stx))))))])))
;; Syntax -> Dict<Symbol, Id> Dict<Symbol, Id>
;; Dict<Symbol, (List Symbol Symbol)> Dict<Symbol, Id>

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

@ -517,6 +517,24 @@
[tc-e (class object% (super-new)
(define x "foo") (string-append x "bar"))
(-class)]
;; private field with function
[tc-e (class object%
(super-new)
(: f (-> String))
(define (f) "foo"))
(-class)]
[tc-err (let ()
(class object%
(super-new)
(: f (-> String))
(define (f) 'bad))
(error "foo"))
#:msg #rx"type mismatch.*expected: \\(-> String\\)"]
;; multiple names in define-values private fields
[tc-e (class object%
(super-new)
(define-values (x y z) (values 'x 'y 'z)))
(-class)]
;; test private method
[tc-e (let ()
(class object% (super-new)