From 6c0e82f15bc1dda5b984d4ddf21c41de9eb80315 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Sat, 18 May 2013 16:46:19 -0400 Subject: [PATCH] Add support for local field access --- .../typed-racket/base-env/class-prims.rkt | 8 +- .../typecheck/check-class-unit.rkt | 130 +++++++++++++----- .../typed-racket/unit-tests/class-tests.rkt | 18 ++- 3 files changed, 117 insertions(+), 39 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt index 465c5746fc..e68fc16506 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt @@ -293,10 +293,16 @@ (define method-names (append (dict-ref name-dict #'public '()) (dict-ref name-dict #'override '()))) + (define field-names + (append (dict-ref name-dict #'field '()) + (dict-ref name-dict #'init-field '()))) (syntax-property #`(let-values ([(#,@method-names) (values #,@(map (λ (stx) #`(λ () (#,stx))) - method-names))]) + method-names))] + [(#,@field-names) + (values #,@(map (λ (stx) #`(λ () #,stx (set! #,stx 0))) + field-names))]) (void)) 'tr:class:local-table #t))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt index 21b106e5f2..c079d7968f 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt @@ -139,49 +139,104 @@ |# ;; trawl the body for the local name table (define locals (trawl-for-property #'body 'tr:class:local-table)) - (define local-table - (syntax-parse (car locals) - #:literals (let-values #%plain-app #%plain-lambda) - [(let-values ([(method ...) - (#%plain-app - values - (#%plain-lambda () - (#%plain-app (#%plain-app local-method self1) self2)) - ...)]) - (#%plain-app void)) - (map cons - (syntax->datum #'(method ...)) - (syntax->list #'(local-method ...)))])) + (define-values (local-method-table local-field-table) + (construct-local-mapping-tables (car locals))) ;; find the `super-new` call (or error if missing) (define super-new-stx (trawl-for-property #'body 'tr:class:super-new)) (check-super-new super-new-stx super-inits) ;; trawl the body and find methods and type-check them (define meths (trawl-for-property #'body 'tr:class:method)) - (with-lexical-env/extend (map (λ (m) (dict-ref local-table m)) - (set->list this%-method-names)) - ;; FIXME: the types we put here are fine in the expected - ;; case, but not if the class doesn't have an annotation. - ;; Then we need to hunt down annotations in a first pass. - ;; (should probably do this in expected case anyway) - ;; FIXME: this doesn't work because the names of local methods - ;; are obscured and need to be reconstructed somehow - (map (λ (m) (->* (list (make-Univ)) - (fixup-method-type (car (dict-ref methods m)) - self-type))) - (set->list this%-method-names)) - (for ([meth meths]) - (define method-name (syntax-property meth 'tr:class:method)) - (define method-type - (fixup-method-type - (car (dict-ref methods method-name)) - self-type)) - (define expected (ret method-type)) - (define annotated (annotate-method meth self-type)) - (tc-expr/check annotated expected))) + (define-values (lexical-names lexical-types) + (local-tables->lexical-env local-method-table methods this%-method-names + local-field-table fields this%-field-names + self-type)) + (with-lexical-env/extend lexical-names lexical-types + (check-methods meths methods self-type)) ;; trawl the body for top-level expressions too (define top-level-exprs (trawl-for-property #'body 'tr:class:top-level)) (void)])) +;; local-tables->lexical-env : Dict Dict List +;; Dict Dict List +;; Type +;; -> List List +;; Construct mappings to put into the lexical type-checking environment +;; from the class local accessor mappings +;; +;; FIXME: the types we put here are fine in the expected +;; case, but not if the class doesn't have an annotation. +;; Then we need to hunt down annotations in a first pass. +;; (should probably do this in expected case anyway) +(define (local-tables->lexical-env local-method-table methods method-names + local-field-table fields field-names + self-type) + (define (localize local-table names) + (map (λ (m) (dict-ref local-table m)) + (set->list names))) + (define localized-method-names (localize local-method-table method-names)) + (define localized-field-pairs (localize local-field-table field-names)) + (define localized-field-get-names (map car localized-field-pairs)) + (define localized-field-set-names (map cadr localized-field-pairs)) + (define method-types + (map (λ (m) (->* (list (make-Univ)) + (fixup-method-type (car (dict-ref methods m)) + self-type))) + (set->list method-names))) + (define field-get-types + (map (λ (f) (->* (list (make-Univ)) (car (dict-ref fields f)))) + (set->list field-names))) + (define field-set-types + (map (λ (f) (->* (list (make-Univ) (car (dict-ref fields f))) + -Void)) + (set->list field-names))) + (values (append localized-method-names + localized-field-get-names localized-field-set-names) + (append method-types field-get-types field-set-types))) + +;; check-methods : Listof Dict Type -> Void +;; Type-check the methods inside of a class +(define (check-methods meths methods self-type) + (for ([meth meths]) + (define method-name (syntax-property meth 'tr:class:method)) + (define method-type + (fixup-method-type + (car (dict-ref methods method-name)) + self-type)) + (define expected (ret method-type)) + (define annotated (annotate-method meth self-type method-type)) + (tc-expr/check annotated expected))) + +;; Syntax -> Dict Dict +;; Construct tables mapping internal method names to the accessors +;; generated inside the untyped class macro. +(define (construct-local-mapping-tables stx) + (syntax-parse stx + #:literals (let-values #%plain-app #%plain-lambda values) + ;; See base-env/class-prims.rkt to see how this in-syntax + ;; table is constructed at the surface syntax + [(let-values ([(method:id ...) + (#%plain-app + values + (#%plain-lambda () + (#%plain-app (#%plain-app local-method:id _) _)) + ...)] + [(field:id ...) + (#%plain-app + values + (#%plain-lambda () + (let-values (((_) _)) (#%plain-app local-field-get:id _)) + (let-values (((_) _)) + (let-values (((_) _)) (#%plain-app local-field-set:id _ _)))) + ...)]) + (#%plain-app void)) + (values (map cons + (syntax->datum #'(method ...)) + (syntax->list #'(local-method ...))) + (map list + (syntax->datum #'(field ...)) + (syntax->list #'(local-field-get ...)) + (syntax->list #'(local-field-set ...))))])) + ;; check-super-new : Listof Inits -> Void ;; Check if the super-new call is well-typed (define (check-super-new super-new-stx super-inits) @@ -244,8 +299,9 @@ [_ (tc-error "fixup-method-type: internal error")])) ;; annotate-method : Syntax Type -> Syntax -;; Adds a self type annotation for the first argument -(define (annotate-method stx self-type) +;; Adds a self type annotation for the first argument and annotated +;; the let-values binding for tc-expr +(define (annotate-method stx self-type method-type) (syntax-parse stx #:literals (let-values #%plain-lambda) [(let-values ([(meth-name:id) @@ -254,7 +310,7 @@ m) (define annotated-self-param (type-ascription-property #'self-param self-type)) - #`(let-values ([(meth-name) + #`(let-values ([(#,(syntax-property #'meth-name 'type-label method-type)) (#%plain-lambda (#,annotated-self-param id ...) body ...)]) m)] diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt index 7dd295bae5..70bf6186b0 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/class-tests.rkt @@ -285,5 +285,21 @@ (check-err (: d% (Class [m (Integer -> Integer)])) (define d% (class: object% (super-new) - (define/override (m y) (* 2 y))))))) + (define/override (m y) (* 2 y))))) + + ;; local field access and set! + (check-ok + (: c% (Class (field [x Integer]) + [m (Integer -> Integer)])) + (define c% (class: object% (super-new) + (field [x 0]) + (define/public (m y) + (begin0 x (set! x (+ x 1))))))) + + ;; fails, missing local field + (check-err + (: c% (Class [m (Integer -> Integer)])) + (define c% (class: object% (super-new) + (define/public (m y) + (begin0 x (set! x (+ x 1)))))))))