From dd208670d507233fb9d2ad6d11c990dac97962a1 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Tue, 13 Aug 2013 17:25:00 -0400 Subject: [PATCH] Reorganize functions for type parameters This refactoring saves some lines and reduces the ridiculous number of arguments for some helper functions. (using a hash table instead of arguments) This will help for adding type parameter name scoping later. original commit: 3c044e23fda47897b77676f5c9d8c9434754581e --- .../typecheck/check-class-unit.rkt | 625 +++++++++--------- 1 file changed, 330 insertions(+), 295 deletions(-) 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 e5419a05..cc5162cd 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 @@ -164,15 +164,16 @@ (define (check-class form [expected #f]) (match (and expected (resolve expected)) [(tc-result1: (and self-class-type (Class: _ _ _ _ _))) - (do-check form self-class-type)] + (parse-and-check form self-class-type)] [(tc-result1: (Poly-names: ns body-type)) (check-class form (ret body-type))] - [#f (do-check form #f)] - [_ (check-below (do-check form #f) expected)])) + [#f (parse-and-check form #f)] + [_ (check-below (parse-and-check form #f) expected)])) ;; Syntax Option -> Type -;; Do the actual type-checking -(define (do-check form expected) +;; Parse the syntax and extract useful information to pass to the +;; main type-checking helper function +(define (parse-and-check form expected) (syntax-parse form ;; Inspect the expansion of the class macro for the pieces that ;; we need to type-check like superclass, methods, top-level @@ -182,231 +183,236 @@ ;; FIXME: maybe should check the property on this expression ;; as a sanity check too (define super-type (tc-expr #'cls.superclass-expr)) - (define-values (super-row super-inits super-fields - super-methods super-augments) - (match super-type - [(tc-result1: (Class: super-row super-inits super-fields - super-methods super-augments)) - (values super-row super-inits super-fields - super-methods super-augments)] - [(tc-result1: t) - (tc-error/expr "expected a superclass but got value of type ~a" t - #:stx #'cls.superclass-expr) - (values #f null null null null)])) - ;; Define sets of names for use later - (define super-init-names (dict-keys super-inits)) - (define super-field-names (dict-keys super-fields)) - (define super-method-names (dict-keys super-methods)) - (define super-augment-names (dict-keys super-augments)) - (define this%-init-internals - (set-union (syntax->datum #'cls.init-internals) - (syntax->datum #'cls.init-field-internals))) - (define this%-public-internals (syntax->datum #'cls.public-internals)) - (define this%-override-internals (syntax->datum #'cls.override-internals)) - (define this%-pubment-internals (syntax->datum #'cls.pubment-internals)) - (define this%-augment-internals (syntax->datum #'cls.augment-internals)) - (define this%-method-internals - (set-union this%-public-internals this%-override-internals)) - (define this%-field-internals - (set-union (syntax->datum #'cls.field-internals) - (syntax->datum #'cls.init-field-internals))) - (define this%-inherit-internals - (syntax->datum #'cls.inherit-internals)) - (define this%-inherit-field-internals - (syntax->datum #'cls.inherit-field-internals)) - (define this%-init-names - (set-union (syntax->datum #'cls.init-externals) - (syntax->datum #'cls.init-field-externals))) - (define this%-field-names - (set-union (syntax->datum #'cls.field-externals) - (syntax->datum #'cls.init-field-externals))) - (define this%-public-names (syntax->datum #'cls.public-externals)) - (define this%-override-names (syntax->datum #'cls.override-externals)) - (define this%-pubment-names (syntax->datum #'cls.pubment-externals)) - (define this%-augment-names (syntax->datum #'cls.augment-externals)) - (define this%-inherit-names (syntax->datum #'cls.inherit-externals)) - (define this%-inherit-field-names - (syntax->datum #'cls.inherit-field-externals)) - (define this%-private-names (syntax->datum #'cls.private-names)) - (define this%-private-fields (syntax->datum #'cls.private-field-names)) - (define this%-overridable-names - (set-union this%-public-names this%-override-names)) - (define this%-augmentable-names - (set-union this%-augment-names this%-pubment-names)) - (define this%-method-names - (set-union this%-overridable-names this%-augmentable-names)) - (define all-internal - (set-union this%-init-internals - this%-field-internals - this%-public-internals - this%-override-internals - this%-inherit-internals - this%-inherit-field-internals - this%-pubment-internals - this%-augment-internals)) - (define all-external - (set-union this%-init-names - this%-field-names - this%-public-names - this%-override-names - this%-inherit-names - this%-inherit-field-names - this%-pubment-names - this%-augment-names)) - ;; establish a mapping between internal and external names - (define internal-external-mapping - (for/hash ([internal all-internal] - [external all-external]) - (values internal external))) - ;; trawl the body for top-level expressions - (define top-level-exprs (trawl-for-property #'cls.make-methods 'tr:class:top-level)) - ;; augment annotations go in their own table, because they're - ;; 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 (annotation-table augment-annotation-table) - ((compose (setup-pubment-defaults this%-pubment-names) - register-annotations) - top-level-exprs)) - ;; find the `super-new` call (or error if missing) - (define super-new-stxs (trawl-for-property #'cls.make-methods 'tr:class:super-new)) - (define super-new-stx (check-super-new-exists super-new-stxs)) - (define provided-super-inits - (if super-new-stx - (find-provided-inits super-new-stx super-inits) - '())) - (define provided-init-names (dict-keys provided-super-inits)) - (define remaining-super-inits - (for/list ([(name val) (in-dict super-inits)] - #:unless (member name provided-init-names)) - (cons name val))) - ;; define which init names are optional - (define optional-inits (syntax->datum #'cls.optional-inits)) - (define optional-external (for/set ([n optional-inits]) - (dict-ref internal-external-mapping n))) - (define optional-super - (for/set ([(name val) (in-dict remaining-super-inits)] - #:when (cadr val)) - name)) - ;; Type for self in method calls - (define self-type - (infer-self-type super-row - expected - annotation-table - augment-annotation-table - optional-inits - internal-external-mapping - remaining-super-inits - super-fields - super-methods - super-augments - this%-init-internals - this%-field-internals - this%-public-internals - this%-pubment-internals)) - (match-define (Instance: (Class: _ inits fields methods augments)) - self-type) - ;; trawl the body for the local name table - (define locals - (trawl-for-property #'cls.make-methods 'tr:class:local-table)) - (define-values (local-method-table local-private-table local-field-table - local-private-field-table local-init-table - local-inherit-table local-inherit-field-table - local-super-table - local-augment-table local-inner-table) - (construct-local-mapping-tables (car locals))) - ;; types for private elements - (define private-method-types - (for/hash ([(name type) (in-dict annotation-table)] - #:when (set-member? this%-private-names name)) - (values name type))) - (define private-field-types - (for/hash ([(name type) (in-dict annotation-table)] - #:when (set-member? this%-private-fields name)) - (values name (list type)))) - ;; start type-checking elements in the body - (define-values (lexical-names lexical-types - lexical-names/top-level lexical-types/top-level) - (local-tables->lexical-env internal-external-mapping - local-method-table methods - this%-method-internals - local-field-table fields - this%-field-internals - local-private-field-table private-field-types - this%-private-fields - local-init-table inits - ;; omit init-fields here since they don't have - ;; init accessors, only field accessors - (syntax->datum #'cls.init-internals) - local-inherit-table - local-inherit-field-table - local-super-table - super-methods super-fields - this%-inherit-internals - this%-inherit-field-internals - this%-override-internals - local-augment-table local-inner-table - augments super-augments - this%-pubment-internals - this%-augment-internals - local-private-table private-method-types - this%-private-names - #'cls.initializer-self-id - #'cls.initializer-args-id - self-type)) - (with-lexical-env/extend lexical-names/top-level lexical-types/top-level - (check-super-new provided-super-inits super-inits)) - (with-lexical-env/extend lexical-names/top-level lexical-types/top-level - (for ([stx top-level-exprs] - #:unless (syntax-property stx 'tr:class:super-new)) - (tc-expr stx))) - (with-lexical-env/extend lexical-names/top-level lexical-types/top-level - (check-field-set!s #'cls.initializer-body local-field-table inits)) - ;; trawl the body and find methods and type-check them - (define meth-stxs (trawl-for-property #'cls.make-methods 'tr:class:method)) - (define checked-method-types - (with-lexical-env/extend lexical-names lexical-types - (check-methods (append this%-pubment-names - this%-overridable-names) - internal-external-mapping meth-stxs - methods self-type))) - (define checked-augment-types - (with-lexical-env/extend lexical-names lexical-types - (check-methods this%-augment-names - internal-external-mapping meth-stxs - augments self-type))) - (with-lexical-env/extend lexical-names lexical-types - (check-private-methods meth-stxs this%-private-names - private-method-types self-type)) - (define final-class-type - (merge-types self-type checked-method-types checked-augment-types)) - (check-method-presence-and-absence - expected - this%-init-names this%-field-names - this%-public-names this%-override-names - this%-inherit-names this%-inherit-field-names - this%-pubment-names this%-augment-names - (set-union optional-external optional-super) - remaining-super-inits super-field-names - super-method-names - super-augment-names) - (when expected - (check-below final-class-type expected)) - final-class-type])) + ;; Save parse attributes to pass through to helper functions + (define parse-info + (hash 'superclass-expr #'cls.superclass-expr + 'make-methods #'cls.make-methods + 'initializer-self-id #'cls.initializer-self-id + 'initializer-args-id #'cls.initializer-args-id + 'initializer-body #'cls.initializer-body + 'optional-inits (syntax->datum #'cls.optional-inits) + 'only-init-internals (syntax->datum #'cls.init-internals) + 'only-init-names (syntax->datum #'cls.init-externals) + 'init-internals + (set-union (syntax->datum #'cls.init-internals) + (syntax->datum #'cls.init-field-internals)) + 'public-internals (syntax->datum #'cls.public-internals) + 'override-internals (syntax->datum #'cls.override-internals) + 'pubment-internals (syntax->datum #'cls.pubment-internals) + 'augment-internals (syntax->datum #'cls.augment-internals) + 'method-internals + (set-union (syntax->datum #'cls.public-internals) + (syntax->datum #'cls.override-internals)) + 'field-internals + (set-union (syntax->datum #'cls.field-internals) + (syntax->datum #'cls.init-field-internals)) + 'inherit-internals + (syntax->datum #'cls.inherit-internals) + 'inherit-field-internals + (syntax->datum #'cls.inherit-field-internals) + 'init-names + (set-union (syntax->datum #'cls.init-externals) + (syntax->datum #'cls.init-field-externals)) + 'field-names + (set-union (syntax->datum #'cls.field-externals) + (syntax->datum #'cls.init-field-externals)) + 'public-names (syntax->datum #'cls.public-externals) + 'override-names (syntax->datum #'cls.override-externals) + 'pubment-names (syntax->datum #'cls.pubment-externals) + 'augment-names (syntax->datum #'cls.augment-externals) + 'inherit-names (syntax->datum #'cls.inherit-externals) + 'inherit-field-names + (syntax->datum #'cls.inherit-field-externals) + 'private-names (syntax->datum #'cls.private-names) + 'private-fields (syntax->datum #'cls.private-field-names) + 'overridable-names + (set-union (syntax->datum #'cls.public-externals) + (syntax->datum #'cls.override-externals)) + 'augmentable-names + (set-union (syntax->datum #'cls.pubment-externals) + (syntax->datum #'cls.augment-externals)) + 'method-names + (set-union (syntax->datum #'cls.public-externals) + (syntax->datum #'cls.override-externals) + (syntax->datum #'cls.augment-externals) + (syntax->datum #'cls.pubment-externals)) + 'all-internal + (set-union (syntax->datum #'cls.init-internals) + (syntax->datum #'cls.init-field-internals) + (syntax->datum #'cls.field-internals) + (syntax->datum #'cls.public-internals) + (syntax->datum #'cls.override-internals) + (syntax->datum #'cls.inherit-internals) + (syntax->datum #'cls.inherit-field-internals) + (syntax->datum #'cls.pubment-internals) + (syntax->datum #'cls.augment-internals)) + 'all-external + (set-union (syntax->datum #'cls.init-externals) + (syntax->datum #'cls.init-field-externals) + (syntax->datum #'cls.field-externals) + (syntax->datum #'cls.public-externals) + (syntax->datum #'cls.override-externals) + (syntax->datum #'cls.inherit-externals) + (syntax->datum #'cls.inherit-field-externals) + (syntax->datum #'cls.pubment-externals) + (syntax->datum #'cls.augment-externals)))) + (do-check expected super-type parse-info)])) -;; check-method-presence-and-absence : Type Set * 12 -> Void +;; do-check : Type Type Dict -> Type +;; The actual type-checking +(define (do-check expected super-type parse-info) + ;; unpack superclass names and types + (define-values (super-row super-inits super-fields + super-methods super-augments) + (match super-type + [(tc-result1: (Class: super-row super-inits super-fields + super-methods super-augments)) + (values super-row super-inits super-fields + super-methods super-augments)] + [(tc-result1: t) + (tc-error/expr "expected a superclass but got value of type ~a" t + #:stx (hash-ref parse-info 'superclass-expr)) + (values #f null null null null)])) + (define super-init-names (dict-keys super-inits)) + (define super-field-names (dict-keys super-fields)) + (define super-method-names (dict-keys super-methods)) + (define super-augment-names (dict-keys super-augments)) + ;; establish a mapping between internal and external names + (define internal-external-mapping + (for/hash ([internal (hash-ref parse-info 'all-internal)] + [external (hash-ref parse-info 'all-external)]) + (values internal external))) + ;; trawl the body for top-level expressions + (define make-methods-stx (hash-ref parse-info 'make-methods)) + (define top-level-exprs + (trawl-for-property make-methods-stx 'tr:class:top-level)) + ;; augment annotations go in their own table, because they're + ;; 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 (annotation-table augment-annotation-table) + ((compose (setup-pubment-defaults (hash-ref parse-info 'pubment-names)) + register-annotations) + top-level-exprs)) + ;; find the `super-new` call (or error if missing) + (define super-new-stxs + (trawl-for-property make-methods-stx 'tr:class:super-new)) + (define super-new-stx (check-super-new-exists super-new-stxs)) + (define provided-super-inits + (if super-new-stx + (find-provided-inits super-new-stx super-inits) + '())) + (define provided-init-names (dict-keys provided-super-inits)) + (define remaining-super-inits + (for/list ([(name val) (in-dict super-inits)] + #:unless (member name provided-init-names)) + (cons name val))) + ;; define which init names are optional + (define optional-inits (hash-ref parse-info 'optional-inits)) + (define optional-external (for/set ([n optional-inits]) + (dict-ref internal-external-mapping n))) + (define optional-super + (for/set ([(name val) (in-dict remaining-super-inits)] + #:when (cadr val)) + name)) + ;; Type for self in method calls + (define self-type + (infer-self-type parse-info + super-row + expected + annotation-table + augment-annotation-table + optional-inits + internal-external-mapping + remaining-super-inits + super-fields + super-methods + super-augments)) + (match-define (Instance: (Class: _ inits fields methods augments)) + self-type) + ;; trawl the body for the local name table + (define locals + (trawl-for-property make-methods-stx 'tr:class:local-table)) + (define-values (local-method-table local-private-table local-field-table + local-private-field-table local-init-table + local-inherit-table local-inherit-field-table + local-super-table + local-augment-table local-inner-table) + (construct-local-mapping-tables (car locals))) + ;; types for private elements + (define private-method-types + (for/hash ([(name type) (in-dict annotation-table)] + #:when (set-member? (hash-ref parse-info 'private-names) name)) + (values name type))) + (define private-field-types + (for/hash ([(name type) (in-dict annotation-table)] + #:when (set-member? (hash-ref parse-info 'private-fields) name)) + (values name (list type)))) + ;; start type-checking elements in the body + (define-values (lexical-names lexical-types + lexical-names/top-level lexical-types/top-level) + (local-tables->lexical-env parse-info + internal-external-mapping + local-method-table methods + local-field-table fields + local-private-field-table private-field-types + local-init-table inits + local-inherit-table + local-inherit-field-table + local-super-table + super-methods super-fields + local-augment-table local-inner-table + augments super-augments + local-private-table private-method-types + self-type)) + (with-lexical-env/extend lexical-names/top-level lexical-types/top-level + (check-super-new provided-super-inits super-inits)) + (with-lexical-env/extend lexical-names/top-level lexical-types/top-level + (for ([stx top-level-exprs] + #:unless (syntax-property stx 'tr:class:super-new)) + (tc-expr stx))) + (with-lexical-env/extend lexical-names/top-level lexical-types/top-level + (check-field-set!s (hash-ref parse-info 'initializer-body) + local-field-table + inits)) + ;; trawl the body and find methods and type-check them + (define meth-stxs (trawl-for-property make-methods-stx 'tr:class:method)) + (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 + methods self-type))) + (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 + augments self-type))) + (with-lexical-env/extend lexical-names lexical-types + (check-private-methods meth-stxs (hash-ref parse-info 'private-names) + private-method-types self-type)) + (define final-class-type + (merge-types self-type checked-method-types checked-augment-types)) + (check-method-presence-and-absence + parse-info + expected + (set-union optional-external optional-super) + remaining-super-inits + super-field-names + super-method-names + super-augment-names) + (when expected + (check-below final-class-type expected)) + final-class-type) + +;; check-method-presence-and-absence : Dict Type Set ... -> Void ;; use the internal class: information to check whether clauses ;; exist or are absent appropriately (define (check-method-presence-and-absence - expected this%-init-names this%-field-names - this%-public-names this%-override-names - this%-inherit-names - this%-inherit-field-names - this%-pubment-names this%-augment-names + parse-info expected optional-external - remaining-super-inits super-field-names - super-method-names - super-augment-names) + remaining-super-inits + super-field-names super-method-names super-augment-names) (when expected (match-define (Class: _ inits fields methods augments) expected) (define exp-init-names (dict-keys inits)) @@ -417,35 +423,39 @@ (for/set ([(name val) (in-dict inits)] #:when (cadr val)) name)) - (check-same (set-union this%-init-names + (check-same (set-union (hash-ref parse-info 'init-names) (dict-keys remaining-super-inits)) exp-init-names "initialization argument") - (check-same (set-union this%-public-names this%-pubment-names + (check-same (set-union (hash-ref parse-info 'public-names) + (hash-ref parse-info 'pubment-names) super-method-names) exp-method-names "public method") - (check-same (set-union this%-field-names super-field-names) + (check-same (set-union (hash-ref parse-info 'field-names) + super-field-names) exp-field-names "public field") - (check-same (set-union this%-pubment-names this%-augment-names + (check-same (set-union (hash-ref parse-info 'augmentable-names) super-augment-names) exp-augment-names "public augmentable method") (check-same optional-external exp-optional-inits "optional init argument")) - (check-exists super-method-names this%-override-names + (check-exists super-method-names (hash-ref parse-info 'override-names) "overridable method") - (check-exists super-augment-names this%-augment-names + (check-exists super-augment-names (hash-ref parse-info 'augment-names) "augmentable method") (check-exists (set-union super-method-names super-augment-names) - this%-inherit-names + (hash-ref parse-info 'inherit-names) "method") - (check-exists super-field-names this%-inherit-field-names + (check-exists super-field-names (hash-ref parse-info 'inherit-field-names) "field") - (check-absent super-field-names this%-field-names "public field") - (check-absent super-method-names this%-public-names "public method") - (check-absent super-augment-names this%-pubment-names + (check-absent super-field-names (hash-ref parse-info 'field-names) + "public field") + (check-absent super-method-names (hash-ref parse-info 'public-names) + "public method") + (check-absent super-augment-names (hash-ref parse-info 'pubment-names) "public augmentable method")) ;; merge-types : Type Dict Dict -> Type @@ -474,63 +484,72 @@ (make-new-methods methods method-types) (make-new-methods augments augment-types))) -;; local-tables->lexical-env : Dict -;; LocalMapping NameTypeDict Names +;; local-tables->lexical-env : Dict Dict +;; LocalMapping NameTypeDict ;; (for each kind of clause) ... -;; Id Id Type +;; Type ;; -> List List List List ;; Construct mappings to put into the lexical type-checking environment ;; from the class local accessor mappings -(define (local-tables->lexical-env internal-external-mapping - local-method-table methods method-names - local-field-table fields field-names +(define (local-tables->lexical-env parse-info + internal-external-mapping + local-method-table methods + local-field-table fields local-private-field-table - private-field-types private-field-names - local-init-table inits init-names + private-field-types + local-init-table inits local-inherit-table local-inherit-field-table local-super-table super-types super-fields - inherit-names inherit-field-names - override-names local-augment-table local-inner-table augments super-augments - pubment-names augment-names local-private-table - private-types private-methods - self-id init-args-id + private-types self-type) ;; localize to accessor names via the provided tables - (define (localize local-table names) + (define (localize local-table name-key-or-list) + (define names + (if (list? name-key-or-list) + (apply append (map (λ (k) (hash-ref parse-info k)) + name-key-or-list)) + (hash-ref parse-info name-key-or-list))) (for/list ([m names]) (dict-ref local-table m))) - (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 localized-private-field-pairs - (localize local-private-field-table private-field-names)) - (define localized-private-field-get-names - (map car localized-private-field-pairs)) - (define localized-private-field-set-names - (map cadr localized-private-field-pairs)) - (define localized-inherit-field-pairs - (localize local-inherit-field-table inherit-field-names)) - (define localized-inherit-field-get-names - (map car localized-inherit-field-pairs)) - (define localized-inherit-field-set-names - (map cadr localized-inherit-field-pairs)) - (define localized-inherit-names (localize local-inherit-table inherit-names)) - (define localized-private-methods - (localize local-private-table private-methods)) - (define localized-override-names - (localize local-super-table override-names)) - (define localized-pubment-names - (localize local-augment-table pubment-names)) - (define localized-augment-names - (localize local-augment-table augment-names)) - (define localized-inner-names - (localize local-inner-table (set-union pubment-names augment-names))) - (define localized-init-names (localize local-init-table init-names)) + (define-values (localized-method-names + localized-field-pairs + localized-private-field-pairs + localized-inherit-field-pairs + localized-inherit-names + localized-private-methods + localized-override-names + localized-pubment-names + localized-augment-names + localized-inner-names + localized-init-names) + (values + (localize local-method-table 'method-internals) + (localize local-field-table 'field-internals) + (localize local-private-field-table 'private-fields) + (localize local-inherit-field-table 'inherit-field-internals) + (localize local-inherit-table 'inherit-internals) + (localize local-private-table 'private-names) + (localize local-super-table 'override-internals) + (localize local-augment-table 'pubment-internals) + (localize local-augment-table 'augment-internals) + (localize local-inner-table '(pubment-internals augment-internals)) + (localize local-init-table 'only-init-internals))) + (define-values (localized-field-get-names + localized-field-set-names + localized-private-field-get-names + localized-private-field-set-names + localized-inherit-field-get-names + localized-inherit-field-set-names) + (values (map car localized-field-pairs) + (map cadr localized-field-pairs) + (map car localized-private-field-pairs) + (map cadr localized-private-field-pairs) + (map car localized-inherit-field-pairs) + (map cadr localized-inherit-field-pairs))) ;; construct the types for method accessors (define (make-method-types method-names type-map @@ -549,15 +568,18 @@ (function->method (car maybe-type) self-type))] [else (make-Univ)])))) - (define method-types (make-method-types method-names methods)) + (define method-types + (make-method-types (hash-ref parse-info 'method-internals) methods)) (define inherit-types (make-method-types - inherit-names + (hash-ref parse-info 'inherit-internals) (append super-types super-augments))) - (define augment-types (make-method-types augment-names augments)) + (define augment-types + (make-method-types (hash-ref parse-info 'augment-internals) augments)) (define inner-types (make-method-types - (set-union pubment-names augment-names) + (set-union (hash-ref parse-info 'pubment-internals) + (hash-ref parse-info 'augment-internals)) augments #:inner? #t)) ;; construct field accessor types @@ -576,12 +598,14 @@ -Void)))) (define-values (field-get-types field-set-types) - (make-field-types field-names fields)) + (make-field-types (hash-ref parse-info 'field-internals) fields)) (define-values (private-field-get-types private-field-set-types) - (make-field-types private-field-names private-field-types + (make-field-types (hash-ref parse-info 'private-fields) + private-field-types #:private? #t)) (define-values (inherit-field-get-types inherit-field-set-types) - (make-field-types inherit-field-names super-fields)) + (make-field-types (hash-ref parse-info 'inherit-field-internals) + super-fields)) ;; types for privates and super calls (define (make-private-like-types names type-map) @@ -594,14 +618,19 @@ (make-Univ)))) (define private-method-types - (make-private-like-types private-methods private-types)) + (make-private-like-types (hash-ref parse-info 'private-names) + private-types)) (define super-call-types - (make-private-like-types override-names super-types)) + (make-private-like-types (hash-ref parse-info 'override-internals) + super-types)) (define pubment-types - (make-private-like-types pubment-names methods)) + (make-private-like-types (hash-ref parse-info 'pubment-internals) + methods)) + ;; omit init-fields here since they don't have + ;; init accessors, only field accessors (define init-types - (for/list ([i (in-set init-names)]) + (for/list ([i (in-set (hash-ref parse-info 'only-init-internals))]) (define external (dict-ref internal-external-mapping i)) (car (dict-ref inits external (list -Bottom))))) @@ -635,7 +664,8 @@ ;; to Any, so that accessors can use them without ;; problems. ;; Be careful though! - (list self-id init-args-id)) + (list (hash-ref parse-info 'initializer-self-id) + (hash-ref parse-info 'initializer-args-id))) (append all-types init-types (list self-type (make-Univ))))) @@ -1011,20 +1041,20 @@ (dict-ref annotations name)))] [else (values annotations augment-annotations)]))) -;; infer-self-type : RowVar Class Dict Dict +;; infer-self-type : Dict RowVar Class Dict Dict ;; Set Dict ;; Inits Fields Methods -;; Set * 4 -> Type +;; -> Type ;; Construct a self object type based on all type annotations ;; and the expected type -(define (infer-self-type super-row +(define (infer-self-type parse-info + super-row expected annotation-table augment-annotation-table optional-inits internal-external-mapping super-inits super-fields super-methods - super-augments - inits fields publics pubments) + super-augments) (define (make-type-dict names supers maybe-expected #:inits [inits? #f] #:annotations-from [annotation-table annotation-table] @@ -1053,6 +1083,11 @@ [(Class: _ inits fields publics augments) (values inits fields publics augments)] [_ (values #f #f #f #f)])) + (define-values (inits fields publics pubments) + (values (hash-ref parse-info 'init-internals) + (hash-ref parse-info 'field-internals) + (hash-ref parse-info 'public-internals) + (hash-ref parse-info 'pubment-internals))) (define init-types (make-type-dict inits super-inits expected-inits #:inits #t)) (define field-types (make-type-dict fields super-fields expected-fields))