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

Better support for class top-level behavior

Browse Source
This commit is contained in:
Asumu Takikawa 2013-05-23 11:01:34 -04:00
parent b9a175eed2
commit 0d5a775a62
2 changed files with 60 additions and 20 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -71,41 +71,42 @@
(define-syntax-class initializer-class (define-syntax-class initializer-class
#:literals (#%plain-lambda) #:literals (#%plain-lambda)
#:attributes (val) #:attributes (initializer-body initializer-self-id
initializer-args-id)
(pattern (#%plain-lambda (pattern (#%plain-lambda
(self:id super-go:id si_c:id si_inited?:id (self:id super-go:id si_c:id si_inited?:id
si_leftovers:id init-args:id) si_leftovers:id init-args:id)
body:initializer-body) body:initializer-body)
#:with val #'body.val)) #:with initializer-body #'body.val
#:with initializer-self-id #'self
#:with initializer-args-id #'init-args))
(define-syntax-class make-methods-body (define-syntax-class make-methods-body
#:literals (let-values letrec-syntaxes+values #%plain-app values) #:literals (let-values letrec-syntaxes+values #%plain-app values)
#:attributes (initializer-body) #:attributes (initializer-body initializer-self-id
initializer-args-id)
(pattern (letrec-values _ (pattern (letrec-values _
(#%plain-app (#%plain-app
values values
public:expr public:expr
override:expr override:expr
augride:expr augride:expr
initializer:initializer-class)) :initializer-class)))
#:with initializer-body #'initializer.val) (pattern (let-values () :make-methods-body))
(pattern (let-values () body:make-methods-body) (pattern (letrec-syntaxes+values _ _ :make-methods-body)))
#:with initializer-body #'body.initializer-body)
(pattern (letrec-syntaxes+values _ _ body:make-methods-body)
#:with initializer-body #'body.initializer-body))
(define-syntax-class make-methods-class (define-syntax-class make-methods-class
#:literals (let-values #%plain-lambda) #:literals (let-values #%plain-lambda)
#:attributes (initializer-body) #:attributes (initializer-body initializer-self-id
initializer-args-id)
(pattern (#%plain-lambda (pattern (#%plain-lambda
(local-accessor:id local-mutator:id local-method-or-field:id ...) (local-accessor:id local-mutator:id local-method-or-field:id ...)
(let-values ([(field-name:id) accessor-or-mutator] ...) (let-values ([(field-name:id) accessor-or-mutator] ...)
body:make-methods-body)) :make-methods-body))))
#:with initializer-body #'body.initializer-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)
#:attributes (superclass-expr initializer-body #:attributes (superclass-expr
init-internals init-externals init-internals init-externals
init-field-internals init-field-externals init-field-internals init-field-externals
optional-inits optional-inits
@ -113,7 +114,10 @@
public-internals public-externals public-internals public-externals
override-internals override-externals override-internals override-externals
private-names private-names
make-methods) make-methods
initializer-body
initializer-self-id
initializer-args-id)
(pattern (let-values () (pattern (let-values ()
(letrec-syntaxes+values (letrec-syntaxes+values
() ()
@ -124,9 +128,8 @@
(#%plain-app (#%plain-app
compose-class:id compose-class:id
internal:expr ... internal:expr ...
make-methods:make-methods-class (~and make-methods :make-methods-class)
(quote #f))))) (quote #f)))))))
#:with initializer-body #'make-methods.initializer-body))
;; Syntax TCResults -> Type ;; Syntax TCResults -> Type
;; Type-check a class form by trawling its innards ;; Type-check a class form by trawling its innards
@ -282,6 +285,8 @@
(list->set (syntax->datum #'cls.init-internals)) (list->set (syntax->datum #'cls.init-internals))
local-private-table private-method-types local-private-table private-method-types
this%-private-names this%-private-names
#'cls.initializer-self-id
#'cls.initializer-args-id
self-type)) self-type))
(with-lexical-env/extend lexical-names/top-level lexical-types/top-level (with-lexical-env/extend lexical-names/top-level lexical-types/top-level
(check-super-new provided-super-inits super-inits)) (check-super-new provided-super-inits super-inits))
@ -363,7 +368,7 @@
;; local-tables->lexical-env : Dict<Symbol, Symbol> ;; local-tables->lexical-env : Dict<Symbol, Symbol>
;; Dict<Symbol, Id> Dict List<Symbol> ;; Dict<Symbol, Id> Dict List<Symbol>
;; Dict<Symbol, (List Id Id)> Dict List<Symbol> ;; Dict<Symbol, (List Id Id)> Dict List<Symbol>
;; Type ;; Id Id Type
;; -> List<Id> List<Type> List<Id> List<Type> ;; -> List<Id> List<Type> List<Id> List<Type>
;; Construct mappings to put into the lexical type-checking environment ;; Construct mappings to put into the lexical type-checking environment
;; from the class local accessor mappings ;; from the class local accessor mappings
@ -373,6 +378,7 @@
local-init-table inits init-names local-init-table inits init-names
local-private-table local-private-table
private-types private-methods private-types private-methods
self-id init-args-id
self-type) self-type)
;; localize to accessor names via the provided tables ;; localize to accessor names via the provided tables
(define (localize local-table names) (define (localize local-table names)
@ -430,10 +436,16 @@
localized-private-methods localized-private-methods
localized-field-get-names localized-field-get-names
localized-field-set-names localized-field-set-names
localized-init-names) localized-init-names
;; Set `self` to the self-type and `init-args`
;; to Any, so that accessors can use them without
;; problems.
;; Be careful though!
(list self-id init-args-id))
(append method-types private-method-types (append method-types private-method-types
field-get-types field-set-types field-get-types field-set-types
init-types))) init-types
(list self-type (make-Univ)))))
;; check-methods : Listof<Syntax> Dict<Symbol, Symbol> Dict Type ;; check-methods : Listof<Syntax> Dict<Symbol, Symbol> Dict Type
;; -> Dict<Symbol, Type> ;; -> Dict<Symbol, Type>

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

@ -347,6 +347,20 @@
(define/public (m y) 0) (define/public (m y) 0)
(+ 3 5)))) (+ 3 5))))
;; test top-level method call
(check-ok
(: c% (Class [m (Integer -> Integer)]))
(define c% (class: object% (super-new)
(define/public (m y) 0)
(m 3))))
;; test top-level field access
(check-ok
(: c% (Class (field [f String])))
(define c% (class: object% (super-new)
(field [f "foo"])
(string-append f "z"))))
;; fails, bad top-level expression ;; fails, bad top-level expression
(check-err (check-err
(: c% (Class [m (Integer -> Integer)])) (: c% (Class [m (Integer -> Integer)]))
@ -354,6 +368,20 @@
(define/public (m y) 0) (define/public (m y) 0)
(+ "foo" 5)))) (+ "foo" 5))))
;; fails, ill-typed method call
(check-err
(: c% (Class [m (Integer -> Integer)]))
(define c% (class: object% (super-new)
(define/public (m y) 0)
(m "foo"))))
;; fails, ill-typed field access
(check-err
(: c% (Class [f String]))
(define c% (class: object% (super-new)
(field [f "foo"])
(set! f 5))))
;; test private method ;; test private method
(check-ok (check-ok
(class: object% (super-new) (class: object% (super-new)