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

More TR class adjustments for expansion changes

Browse Source
This commit is contained in:
Asumu Takikawa 2014-04-17 15:34:58 -04:00
parent 4bf1f90c3c
commit 0ce0abb2c2
1 changed files with 39 additions and 24 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -517,17 +517,18 @@
(syntax-parse expr (syntax-parse expr
#:literal-sets (kernel-literals) #:literal-sets (kernel-literals)
#:literals (:-augment) #:literals (:-augment)
;; FIXME: this case seems too loose, many things can match this syntax
;; we likely need to set a property or match against another name
[(begin [(begin
(quote ((~datum declare-field-assignment) _)) (quote ((~datum declare-field-initialization) _))
(let-values ([(obj:id) self]) (let-values ([(obj:id) self])
(let-values ([(field:id) initial-value]) (let-values ([(field:id) initial-value])
(#%plain-app setter:id _ _)))) (with-continuation-mark _ _
;; only record the first one, which is the one that initializes (#%plain-app setter:id obj2:id field2:id)))))
;; the field or private field ;; There should only be one initialization expression per field
(unless (dict-has-key? initializers #'setter) ;; since they are distinguished by a declaration.
(free-id-table-set! initializers #'setter #'initial-value)) (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] other-exprs]
;; The second part of this pattern ensures that we find the actual ;; The second part of this pattern ensures that we find the actual
;; initialization call, rather than the '(declare-super-new) in ;; initialization call, rather than the '(declare-super-new) in
@ -908,18 +909,20 @@
;; check-field-set!s : Syntax Dict<Symbol, Symbol> Dict<Symbol, Type> -> Void ;; check-field-set!s : Syntax Dict<Symbol, Symbol> Dict<Symbol, Type> -> Void
;; Check that fields are initialized to the correct type ;; Check that fields are initialized to the correct type
;; FIXME: this function is too long ;; FIXME: use syntax classes for matching and clearly separate the handling
;; of field initialization and set! uses
(define (check-field-set!s stx local-field-table inits) (define (check-field-set!s stx local-field-table inits)
(for ([form (syntax->list stx)]) (for ([form (syntax->list stx)])
(syntax-parse form (syntax-parse form
#:literals (let-values #%plain-app quote) #:literal-sets (kernel-literals)
;; init with default ;; init with default
[(set! internal-init:id [(set! internal-init:id
(begin
(#%plain-app extract-arg:id (#%plain-app extract-arg:id
_ _
(quote init-external:id) (quote init-external:id)
init-args:id init-args:id
init-val:expr)) init-val:expr)))
(define init-name (syntax-e #'init-external)) (define init-name (syntax-e #'init-external))
(define init-type (car (dict-ref inits init-name '(#f)))) (define init-type (car (dict-ref inits init-name '(#f))))
(cond [init-type (cond [init-type
@ -944,7 +947,9 @@
init-name)])] init-name)])]
;; init-field with default ;; init-field with default
[(begin [(begin
(quote ((~datum declare-field-assignment) _)) (quote ((~or (~datum declare-field-assignment)
(~datum declare-field-initialization))
_))
(let-values (((obj1:id) self:id)) (let-values (((obj1:id) self:id))
(let-values (((x:id) (let-values (((x:id)
(#%plain-app extract-arg:id (#%plain-app extract-arg:id
@ -952,7 +957,9 @@
(quote name:id) (quote name:id)
init-args:id init-args:id
init-val:expr))) init-val:expr)))
(#%plain-app local-setter:id obj2:id y:id)))) (~or (with-continuation-mark _ _
(#%plain-app local-setter:id obj2:id y:id))
(#%plain-app local-setter:id obj2:id y:id)))))
#:when (free-identifier=? #'x #'y) #:when (free-identifier=? #'x #'y)
#:when (free-identifier=? #'obj1 #'obj2) #:when (free-identifier=? #'obj1 #'obj2)
(define init-name (syntax-e #'name)) (define init-name (syntax-e #'name))
@ -968,17 +975,25 @@
[else [else
(tc-error/delayed "Init argument ~a has no type annotation" (tc-error/delayed "Init argument ~a has no type annotation"
init-name)])] init-name)])]
;; any field or init-field without default ;; any field or an init-field without default
;; FIXME: could use the local table to make sure the
;; setter is known as a sanity check
[(begin [(begin
(quote ((~datum declare-field-assignment) _)) (quote ((~or (~datum declare-field-assignment)
(~datum declare-field-initialization))
_))
(let-values (((obj1:id) self:id)) (let-values (((obj1:id) self:id))
(let-values (((x:id) init-val:expr)) (let-values (((x:id) init-val:expr))
(#%plain-app local-setter:id obj2:id y:id)))) (~or (with-continuation-mark _ _
(#%plain-app local-setter:id obj2:id y:id))
(#%plain-app local-setter:id obj2:id y:id)))))
#:when (free-identifier=? #'x #'y) #:when (free-identifier=? #'x #'y)
#:when (free-identifier=? #'obj1 #'obj2) #:when (free-identifier=? #'obj1 #'obj2)
(tc-expr form)] ;; Remove wcm for checking since TR can't handle these cases
(define simplified
(syntax/loc form
(let-values (((obj1) self))
(let-values (((x) init-val))
(#%plain-app local-setter obj2 y)))))
(tc-expr simplified)]
[_ (void)]))) [_ (void)])))
;; synthesize-private-field-types : IdTable Dict Hash -> Void ;; synthesize-private-field-types : IdTable Dict Hash -> Void