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

Fix TR class support for new class expansion

Browse Source 
Also add a type for `check-not-unsafe-undefined` which shows
up in the expanded code now.
This commit is contained in:
Asumu Takikawa 2014-04-15 21:15:47 -04:00
parent aa43797b63
commit 9aaaf98b32
2 changed files with 70 additions and 34 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt
View File

@ -6,6 +6,7 @@
(for-template (for-template
(except-in racket -> ->* one-of/c class) (except-in racket -> ->* one-of/c class)
racket/unsafe/ops racket/unsafe/ops
racket/unsafe/undefined
;(only-in rnrs/lists-6 fold-left) ;(only-in rnrs/lists-6 fold-left)
'#%paramz '#%paramz
"extra-procs.rkt" "extra-procs.rkt"
@ -2716,6 +2717,9 @@
[unsafe-struct-set! top-func] [unsafe-struct-set! top-func]
[unsafe-struct*-set! top-func] [unsafe-struct*-set! top-func]
;; Section 17.4 (Unsafe Undefined)
[check-not-unsafe-undefined (-poly (a) (-> a -Symbol a))]
;; Section 18.2 (Libraries and Collections) ;; Section 18.2 (Libraries and Collections)
[find-library-collection-paths (->opt [(-lst -Pathlike) (-lst -Pathlike)] (-lst -Path))] [find-library-collection-paths (->opt [(-lst -Pathlike) (-lst -Pathlike)] (-lst -Path))]
[collection-file-path (->* (list -Pathlike) -Pathlike -Path)] [collection-file-path (->* (list -Pathlike) -Pathlike -Path)]

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

@ -151,7 +151,7 @@
:make-methods-body)))) :make-methods-body))))
(define-syntax-class class-expansion (define-syntax-class class-expansion
#:literals (let-values letrec-syntaxes+values #%plain-app) #:literals (let-values letrec-syntaxes+values #%plain-app quote)
#:attributes (superclass-expr #:attributes (superclass-expr
type-parameters type-parameters
all-init-internals all-init-internals
@ -176,13 +176,15 @@
() ()
((() ;; residual class: data ((() ;; residual class: data
:internal-class-data)) :internal-class-data))
(let-values (((superclass:id) superclass-expr) (#%plain-app
((interfaces:id) interface-expr)) compose-class:id
(#%plain-app name:expr
compose-class:id superclass-expr:expr
internal:expr ... interface-expr:expr
(~and make-methods :make-methods-class) internal:expr ...
(quote #f))))))) (~and make-methods :make-methods-class)
(quote :boolean)
(quote #f))))))
;; This is similar to `type-declaration` from "internal-forms.rkt", but ;; This is similar to `type-declaration` from "internal-forms.rkt", but
;; the expansion is slightly different in a class so we use this instead. ;; the expansion is slightly different in a class so we use this instead.
@ -517,15 +519,20 @@
#:literals (:-augment) #:literals (:-augment)
;; FIXME: this case seems too loose, many things can match this syntax ;; FIXME: this case seems too loose, many things can match this syntax
;; we likely need to set a property or match against another name ;; we likely need to set a property or match against another name
[(let-values ([(obj:id) self]) [(begin
(let-values ([(field:id) initial-value]) (quote ((~datum declare-field-assignment) _))
(#%plain-app setter:id _ _))) (let-values ([(obj:id) self])
(let-values ([(field:id) initial-value])
(#%plain-app setter:id _ _))))
;; only record the first one, which is the one that initializes ;; only record the first one, which is the one that initializes
;; the field or private field ;; the field or private field
(unless (dict-has-key? initializers #'setter) (unless (dict-has-key? initializers #'setter)
(free-id-table-set! initializers #'setter #'initial-value)) (free-id-table-set! initializers #'setter #'initial-value))
other-exprs] other-exprs]
[:tr:class:super-new^ ;; The second part of this pattern ensures that we find the actual
;; initialization call, rather than the '(declare-super-new) in
;; the expansion.
[(~and :tr:class:super-new^ (#%plain-app . rst))
(when super-new (when super-new
(tc-error/delayed "typed classes must only call super-new a single time")) (tc-error/delayed "typed classes must only call super-new a single time"))
(set! super-new (find-provided-inits expr)) (set! super-new (find-provided-inits expr))
@ -830,8 +837,6 @@
super-call-types super-call-types
pubment-types augment-types inner-types)) pubment-types augment-types inner-types))
(values all-names all-types (values all-names all-types
;; FIXME: consider removing method names and types
;; from top-level environment to avoid <undefined>
(append all-names (append all-names
localized-init-names localized-init-names
localized-init-rest-name localized-init-rest-name
@ -909,7 +914,6 @@
(syntax-parse form (syntax-parse form
#:literals (let-values #%plain-app quote) #:literals (let-values #%plain-app quote)
;; init with default ;; init with default
;; FIXME: undefined can appear here
[(set! internal-init:id [(set! internal-init:id
(#%plain-app extract-arg:id (#%plain-app extract-arg:id
_ _
@ -939,14 +943,16 @@
(tc-error/delayed "Init argument ~a has no type annotation" (tc-error/delayed "Init argument ~a has no type annotation"
init-name)])] init-name)])]
;; init-field with default ;; init-field with default
[(let-values (((obj1:id) self:id)) [(begin
(let-values (((x:id) (quote ((~datum declare-field-assignment) _))
(#%plain-app extract-arg:id (let-values (((obj1:id) self:id))
_ (let-values (((x:id)
(quote name:id) (#%plain-app extract-arg:id
init-args:id _
init-val:expr))) (quote name:id)
(#%plain-app local-setter:id obj2:id y:id))) init-args:id
init-val:expr)))
(#%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))
@ -965,9 +971,11 @@
;; any field or init-field without default ;; any field or init-field without default
;; FIXME: could use the local table to make sure the ;; FIXME: could use the local table to make sure the
;; setter is known as a sanity check ;; setter is known as a sanity check
[(let-values (((obj1:id) self:id)) [(begin
(let-values (((x:id) init-val:expr)) (quote ((~datum declare-field-assignment) _))
(#%plain-app local-setter:id obj2:id y:id))) (let-values (((obj1:id) self:id))
(let-values (((x:id) init-val:expr))
(#%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)] (tc-expr form)]
@ -994,7 +1002,8 @@
;; generated inside the untyped class macro. ;; generated inside the untyped class macro.
(define (construct-local-mapping-tables stx) (define (construct-local-mapping-tables stx)
(syntax-parse stx (syntax-parse stx
#:literals (let-values if quote #%plain-app #%plain-lambda values) #:literal-sets (kernel-literals)
#:literals (values)
;; See base-env/class-prims.rkt to see how this in-syntax ;; See base-env/class-prims.rkt to see how this in-syntax
;; table is constructed at the surface syntax ;; table is constructed at the surface syntax
;; ;;
@ -1003,60 +1012,83 @@
(#%plain-app (#%plain-app
values values
(#%plain-lambda () (#%plain-lambda ()
(quote ((~datum declare-this-escapes)))
(#%plain-app (#%plain-app local-method:id _) _)) (#%plain-app (#%plain-app local-method:id _) _))
...)] ...)]
[(private:id ...) [(private:id ...)
(#%plain-app (#%plain-app
values values
(#%plain-lambda () (#%plain-app local-private:id _)) (#%plain-lambda ()
(quote ((~datum declare-this-escapes)))
(#%plain-app local-private:id _))
...)] ...)]
[(field:id ...) [(field:id ...)
(#%plain-app (#%plain-app
values values
(#%plain-lambda () (#%plain-lambda ()
(quote ((~datum declare-field-use) _))
(let-values (((_) _)) (#%plain-app local-field-get:id _)) (let-values (((_) _)) (#%plain-app local-field-get:id _))
(let-values (((_) _)) (begin
(let-values (((_) _)) (#%plain-app local-field-set:id _ _)))) (quote ((~datum declare-field-assignment) _))
(let-values (((_) _))
(let-values (((_) _)) (#%plain-app local-field-set:id _ _)))))
...)] ...)]
[(private-field:id ...) [(private-field:id ...)
(#%plain-app (#%plain-app
values values
(#%plain-lambda () (#%plain-lambda ()
(quote ((~datum declare-field-use) _))
(let-values (((_) _)) (#%plain-app local-private-get:id _)) (let-values (((_) _)) (#%plain-app local-private-get:id _))
(let-values (((_) _)) (begin
(let-values (((_) _)) (#%plain-app local-private-set:id _ _)))) (quote ((~datum declare-field-assignment) _))
(let-values (((_) _))
(let-values (((_) _)) (#%plain-app local-private-set:id _ _)))))
...)] ...)]
[(inherit-field:id ...) [(inherit-field:id ...)
(#%plain-app (#%plain-app
values values
(#%plain-lambda () (#%plain-lambda ()
(quote ((~datum declare-inherit-use) _))
(let-values (((_) _)) (#%plain-app local-inherit-get:id _)) (let-values (((_) _)) (#%plain-app local-inherit-get:id _))
(let-values (((_) _)) (let-values (((_) _))
(let-values (((_) _)) (#%plain-app local-inherit-set:id _ _)))) (let-values (((_) _)) (#%plain-app local-inherit-set:id _ _))))
...)] ...)]
[(init:id ...) [(init:id ...)
(#%plain-app values (#%plain-lambda () local-init:id) ...)] (#%plain-app
values
(#%plain-lambda ()
;; check-not-unsafe-undefined
(#%plain-app _ local-init:id _)) ...)]
[(init-rest:id ...) [(init-rest:id ...)
(#%plain-app values (#%plain-lambda () local-init-rest:id) ...)] (#%plain-app
values
(#%plain-lambda ()
;; check-not-unsafe-undefined
(#%plain-app _ local-init-rest:id _)) ...)]
[(inherit:id ...) [(inherit:id ...)
(#%plain-app (#%plain-app
values values
(#%plain-lambda () (#%plain-lambda ()
(quote ((~datum declare-this-escapes)))
(#%plain-app (#%plain-app local-inherit:id _) _)) (#%plain-app (#%plain-app local-inherit:id _) _))
...)] ...)]
[(override:id ...) [(override:id ...)
(#%plain-app (#%plain-app
values values
(#%plain-lambda () (#%plain-lambda ()
(quote ((~datum declare-this-escapes)))
(#%plain-app (#%plain-app local-override:id _) _) (#%plain-app (#%plain-app local-override:id _) _)
(quote ((~datum declare-this-escapes)))
(#%plain-app local-super:id _)) (#%plain-app local-super:id _))
...)] ...)]
[(augment:id ...) [(augment:id ...)
(#%plain-app (#%plain-app
values values
(#%plain-lambda () (#%plain-lambda ()
(quote ((~datum declare-this-escapes)))
(~or (#%plain-app local-augment:id _) (~or (#%plain-app local-augment:id _)
(#%plain-app (#%plain-app local-augment:id _) _)) (#%plain-app (#%plain-app local-augment:id _) _))
(quote ((~datum declare-this-escapes)))
(let-values ([(_) (#%plain-app local-inner:id _)]) (let-values ([(_) (#%plain-app local-inner:id _)])
(if _ (#%plain-app _ _) _))) (if _ (#%plain-app _ _) _)))
...)]) ...)])