From bc07b8b14022ecf526e043d44ab0b4403e44c574 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Thu, 16 May 2013 15:52:09 -0400 Subject: [PATCH] Initial work on type-checking class expressions Add a `class:` macro that adds instrumentation for the type-checker. Also add type-checking for the expansion of that macro. original commit: 244135a96e8c6e98e6a77052813b53d4f284443f --- .../typed-racket/base-env/base-env.rkt | 4 + .../typed-racket/base-env/class-prims.rkt | 285 ++++++++++++++++++ .../typed-racket/base-env/prims.rkt | 2 + .../typecheck/check-class-unit.rkt | 266 ++++++++++++++++ .../typed-racket/typecheck/signatures.rkt | 4 + .../typed-racket/typecheck/tc-expr-unit.rkt | 11 +- .../typed-racket/typecheck/typechecker.rkt | 6 +- 7 files changed, 575 insertions(+), 3 deletions(-) create mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt create mode 100644 pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt index d4302dd6..e7fe322c 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/base-env.rkt @@ -21,6 +21,7 @@ (only-in (types abbrev) [-Boolean B] [-Symbol Sym]) (only-in (types numeric-tower) [-Number N]) (only-in (rep type-rep) + make-Class make-Name make-ValuesDots make-MPairTop @@ -959,6 +960,9 @@ [struct? (-> Univ -Boolean)] [struct-type? (make-pred-ty (make-StructTypeTop))] +;; Section 6.2 (Classes) +[object% (make-Class #f null null null)] + ;; Section 9.1 [exn:misc:match? (-> Univ B)] ;; this is a hack 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 new file mode 100644 index 00000000..996d77df --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/class-prims.rkt @@ -0,0 +1,285 @@ +#lang racket/base + +;; This module provides TR primitives for classes and objects + +(require racket/class + (for-syntax + racket/base + racket/class + racket/dict + racket/list + racket/pretty ;; get rid of this later + racket/syntax + racket/private/classidmap ;; this is bad + syntax/flatten-begin + syntax/id-table + syntax/kerncase + syntax/parse + syntax/stx + unstable/list + (for-template "../typecheck/internal-forms.rkt") + "../utils/tc-utils.rkt" + "../types/utils.rkt")) + +(provide ;; Typed class macro that coordinates with TR + class: + ;; for use in ~literal clauses + class:-internal) + +;; give it a binding, but it shouldn't be used directly +(define-syntax (class:-internal stx) + (raise-syntax-error "should only be used internally")) + +(begin-for-syntax + (module+ test (require rackunit)) + + ;; basically the same stop forms that class-internal uses + (define stop-forms + (append (kernel-form-identifier-list) + (list + (quote-syntax #%app) + (quote-syntax lambda) + (quote-syntax init) + (quote-syntax init-rest) + (quote-syntax field) + (quote-syntax init-field) + (quote-syntax inherit-field) + (quote-syntax private) + (quote-syntax public) + (quote-syntax override) + (quote-syntax augride) + (quote-syntax public-final) + (quote-syntax override-final) + (quote-syntax augment-final) + (quote-syntax pubment) + (quote-syntax overment) + (quote-syntax augment) + (quote-syntax rename-super) + (quote-syntax inherit) + (quote-syntax inherit/super) + (quote-syntax inherit/inner) + (quote-syntax rename-inner) + (quote-syntax abstract) + (quote-syntax super) + (quote-syntax inner) + (quote-syntax this) + (quote-syntax this%) + (quote-syntax super-instantiate) + (quote-syntax super-make-object) + (quote-syntax super-new) + (quote-syntax inspect))))) + +(begin-for-syntax + ;; A Clause is a (clause Syntax Id Listof) + ;; + ;; interp. a class clause such as init or field. + (struct clause (stx type ids)) + + ;; A NonClause is a (non-clause Syntax) + ;; + ;; interp. a top-level class expression that is not one of the special + ;; class clauses such as init or field. + (struct non-clause (stx)) + + (define-syntax-class init-decl + (pattern id + #:with internal-id #'id + #:with external-id #'id) + (pattern (ren:renamed) + #:with internal-id #'ren.internal-id + #:with external-id #'ren.external-id) + (pattern (mren:maybe-renamed default-value:expr) + #:with internal-id #'mren.internal-id + #:with external-id #'mren.external-id)) + + (define-syntax-class field-decl + (pattern (mren:maybe-renamed default-value:expr) + #:with internal-id #'mren.internal-id + #:with external-id #'mren.external-id)) + + (define-syntax-class renamed + (pattern (internal-id:id external-id:id))) + + (define-syntax-class maybe-renamed + (pattern id + #:with internal-id #'id + #:with external-id #'id) + (pattern ren:renamed + #:with internal-id #'ren.internal-id + #:with external-id #'ren.external-id)) + + (define-syntax-class class-clause + (pattern (~and ((~and clause-name (~or (~literal init) + (~literal init-field))) + names:init-decl ...) + form) + ;; in the future, use a data structure and + ;; make this an attribute instead to represent + ;; internal and external names + #:attr data + (clause #'form #'clause-name + (stx->list #'(names.external-id ...)))) + (pattern (~and ((~literal field) names:field-decl ...) form) + #:attr data (clause #'form #'field + (stx->list #'(names.external-id ...)))) + (pattern (~and ((~and clause-name (~or (~literal inherit-field) + (~literal public) + (~literal pubment) + (~literal public-final) + (~literal override) + (~literal overment) + (~literal override-final) + (~literal augment) + (~literal augride) + (~literal augment-final) + (~literal inherit) + (~literal inherit/super) + (~literal inherit/inner))) + names:maybe-renamed ...) + form) + #:attr data + (clause #'form #'clause-name + (stx->list #'(names.external-id ...)))) + (pattern (~and ((~and clause-name (~or (~literal private) + (~literal abstract))) + names:id ...) + form) + #:attr data + (clause #'form #'clause-name + (stx->list #'(names ...))))) + + (define-syntax-class class-clause-or-other + (pattern e:class-clause #:attr data (attribute e.data)) + (pattern e:expr #:attr data (non-clause #'e))) + + ;; Listof -> Hash + ;; Extract names from init, public, etc. clauses + ;; FIXME: deal with internal vs. external names + (define (extract-names clauses) + (for/fold ([clauses (make-immutable-free-id-table)]) + ([clause clauses]) + (if (dict-has-key? clauses (clause-type clause)) + (dict-update clauses (clause-type clause) + (λ (old-names) + (append old-names (clause-ids clause)))) + (dict-set clauses + (clause-type clause) + (clause-ids clause))))) + + ;; Get rid of class top-level `begin` and local expand + (define ((eliminate-begin expander) stx) + (syntax-parse stx + #:literals (begin) + [(begin e ...) + (stx-map (compose (eliminate-begin expander) expander) + (flatten-begin stx))] + [_ stx])) + + (module+ test + ;; equal? check but considers identifier equality + (define (equal?/id x y) + (if (and (identifier? x) (identifier? y)) + (free-identifier=? x y) + (equal?/recur x y equal?/id))) + + ;; utility macro for checking if a syntax matches a + ;; given syntax class + (define-syntax-rule (syntax-parses? stx syntax-class) + (syntax-parse stx + [(~var _ syntax-class) #t] + [_ #f])) + + ;; for rackunit with equal?/id + (define-binary-check (check-equal?/id equal?/id actual expected)) + + (check-true (syntax-parses? #'x init-decl)) + (check-true (syntax-parses? #'([x y]) init-decl)) + (check-true (syntax-parses? #'(x 0) init-decl)) + (check-true (syntax-parses? #'([x y] 0) init-decl)) + (check-true (syntax-parses? #'(init x y z) class-clause)) + (check-true (syntax-parses? #'(public f g h) class-clause)) + (check-true (syntax-parses? #'(public f) class-clause-or-other)) + (check-equal?/id + (extract-names (list (clause #'(init x y z) #'init (list #'x #'y #'z)) + (clause #'(public f g h) #'public (list #'f #'g #'h)))) + (make-immutable-free-id-table + (hash #'public (list #'f #'g #'h) + #'init (list #'x #'y #'z)))))) + +(define-syntax (class: stx) + (syntax-parse stx + [(_ super e ...) + (define class-context (generate-class-expand-context)) + ;; do a local expansion for class: + (define (class-expand stx) + (local-expand stx class-context stop-forms)) + ;; FIXME: potentially needs to expand super clause? + (define expanded-stx (stx-map class-expand #'(e ...))) + (define flattened-stx + (flatten (map (eliminate-begin class-expand) expanded-stx))) + (syntax-parse flattened-stx + [(class-elems:class-clause-or-other ...) + (define-values (clauses others) + (filter-multiple (attribute class-elems.data) + clause? + non-clause?)) + (define name-dict (extract-names clauses)) + (define-values (annotated-methods other-top-level) + (for/fold ([methods '()] + [rest-top '()]) + ([other others]) + (define stx (non-clause-stx other)) + (syntax-parse stx + ;; if it's a method definition for a declared method, then + ;; mark it as something to type-check + [(define-values (id) . rst) + #:when (memf (λ (n) (free-identifier=? #'id n)) + (dict-ref name-dict #'public)) + (values (cons (non-clause (syntax-property stx + 'tr:class:method + (syntax-e #'id))) + methods) + rest-top)] + ;; FIXME: this needs to handle external/internal names too + ;; FIXME: this needs to track overrides and other things + [_ (values methods (append rest-top (list other)))]))) + (define annotated-super + (syntax-property #'super 'tr:class:super #t)) + (syntax-property + (syntax-property + #`(let-values () + #,(internal + ;; FIXME: maybe put this in a macro and/or a syntax class + ;; so that it's easier to deal with + #`(class:-internal + (init #,@(dict-ref name-dict #'init '())) + (init-field #,@(dict-ref name-dict #'init-field '())) + (field #,@(dict-ref name-dict #'field '())) + (public #,@(dict-ref name-dict #'public '())))) + (class #,annotated-super + #,@(map clause-stx clauses) + #,@(map non-clause-stx annotated-methods) + #,(syntax-property + #`(begin #,@(map non-clause-stx other-top-level)) + 'tr:class:top-level #t) + #,(make-locals-table name-dict))) + 'tr:class #t) + 'typechecker:ignore #t)])])) + +(begin-for-syntax + ;; This is a neat/horrible trick + ;; + ;; In order to detect the mappings that class-internal.rkt has + ;; created for class-local field and method access, we construct + ;; a in-syntax table mapping original names to the accessors. + ;; The identifiers inside the lambdas below will expand via + ;; set!-transformers to the appropriate accessors, which lets + ;; us figure out the accessor identifiers. + (define (make-locals-table name-dict) + (syntax-property + #`(let-values ([(#,@(dict-ref name-dict #'public '())) + (values #,@(map (λ (stx) #`(λ () (#,stx))) + (dict-ref name-dict #'public '())))]) + (void)) + 'tr:class:local-table #t))) + diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt index 4d97f449..1e1c1f81 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt @@ -29,6 +29,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (all-from-out "base-contracted.rkt") (all-from-out "top-interaction.rkt") (all-from-out "case-lambda.rkt") + class: : (rename-out [define-typed-struct define-struct:] [define-typed-struct define-struct] @@ -105,6 +106,7 @@ This file defines two sorts of primitives. All of them are provided into any mod "base-types-extra.rkt" "case-lambda.rkt" 'struct-extraction + "class-prims.rkt" racket/flonum ; for for/flvector and for*/flvector (for-syntax racket/lazy-require 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 new file mode 100644 index 00000000..9b6ab024 --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/check-class-unit.rkt @@ -0,0 +1,266 @@ +#lang racket/unit + +;; This module provides a unit for type-checking classes + +(require "../utils/utils.rkt" + racket/dict + racket/match + racket/pretty ;; DEBUG ONLY + racket/set + syntax/parse + "signatures.rkt" + "tc-metafunctions.rkt" + "tc-funapp.rkt" + "tc-subst.rkt" + (prefix-in c: racket/class) + (private syntax-properties type-annotation) + (base-env class-prims) + (env lexical-env) + (types utils abbrev union subtype resolve) + (utils tc-utils) + (rep type-rep) + (for-template racket/base + (prefix-in c: racket/class) + (base-env class-prims))) + +(import tc-if^ tc-lambda^ tc-app^ tc-let^ tc-expr^) +(export check-class^) + +;; Syntax TCResults -> Void +;; Type-check a class form by trawling its innards +;; +;; Assumptions: +;; by the time this is called, we can be sure that +;; init, field, and method presence/absence is guaranteed +;; by the local-expansion done by class: +;; +;; we know by this point that #'form is an actual typed +;; class produced by class: due to the syntax property +(define (check-class form [expected #f]) + (match expected + [(tc-result1: (and self-class-type (Class: _ inits fields methods))) + (do-check form #t self-class-type inits fields methods)] + [#f (do-check form #f #f null null null)])) + +;; Syntax Boolean Option Inits Fields Methods -> Type +;; Do the actual type-checking +(define (do-check form expected? self-class-type inits fields methods) + (syntax-parse form + #:literals (let-values #%plain-lambda quote-syntax begin + #%plain-app values class:-internal letrec-syntaxes+values + c:init c:init-field c:field c:public) + ;; Inspect the expansion of the class macro for the pieces that + ;; we need to type-check like superclass, methods, top-level + ;; expressions and so on + [(let-values () + (letrec-syntaxes+values () + ((() + ;; residual class: data + ;; FIXME: put in syntax class + (begin + (quote-syntax + (class:-internal + (c:init internal-init-names ...) + (c:init-field internal-init-field-names ...) + (c:field internal-field-names ...) + (c:public internal-public-names ...))) + (#%plain-app values)))) + (let-values (((superclass) superclass-expr) + ((interfaces) interface-expr)) + (?#%app compose-class + internal ... + (#%plain-lambda (local-accessor local-mutator ??? ...) + (let-values ([(field-name) accessor-or-mutator] + ...) + body)) + ????)))) + ;; Type for self in method calls + (define self-type (make-Instance self-class-type)) + ;; Make sure the superclass is a class + ;; FIXME: maybe should check the property on this expression + ;; as a sanity check too + (define super-type (tc-expr #'superclass-expr)) + (define-values (super-inits super-fields super-methods) + (match super-type + ;; FIXME: should handle the case where the super class is + ;; polymorphic + [(tc-result1: (Class: _ super-inits super-fields super-methods)) + (values super-inits super-fields super-methods)] + [(tc-result1: t) + (tc-error/expr "expected a superclass but got ~a" t + #:stx #'superclass-expr) + ;; FIXME: is this the right thing to do? + (values null null null)])) + ;; Define sets of names for use later + (define super-init-names (list->set (dict-keys super-inits))) + (define super-field-names (list->set (dict-keys super-fields))) + (define super-method-names (list->set (dict-keys super-methods))) + (define this%-init-names + (list->set + (append (syntax->datum #'(internal-init-names ...)) + (syntax->datum #'(internal-init-field-names ...))))) + (define this%-field-names + (list->set + (append (syntax->datum #'(internal-field-names ...)) + (syntax->datum #'(internal-init-field-names ...))))) + (define this%-method-names + (list->set (syntax->datum #'(internal-public-names ...)))) + ;; Use the internal class: information to check whether clauses + ;; exist or are absent appropriately + (when expected? + (define exp-init-names (list->set (dict-keys inits))) + (define exp-field-names (list->set (dict-keys fields))) + (define exp-method-names (list->set (dict-keys methods))) + (check-exists (set-union this%-init-names super-init-names) + exp-init-names + "initialization argument") + (check-exists (set-union this%-method-names super-method-names) + exp-method-names + "public method") + (check-exists (set-union this%-field-names super-field-names) + exp-field-names + "public field")) + (check-absent super-field-names this%-field-names "public field") + (check-absent super-method-names this%-method-names "public method") + ;; FIXME: the control flow for the failure of these checks is + ;; still up in the air + #| + (check-no-extra (set-union this%-field-names super-field-names) + exp-field-names) + (check-no-extra (set-union this%-method-names super-method-names) + exp-method-names) + |# + ;; 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 ...)))])) + ;; 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)) + (syntax->datum #'(internal-public-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))) + (syntax->datum #'(internal-public-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))) + ;; trawl the body for top-level expressions too + (define top-level-exprs (trawl-for-property #'body 'tr:class:top-level)) + (void)])) + +;; Syntax -> Listof +;; Look through the expansion of the class macro in search for +;; syntax with some property (e.g., methods) +(define (trawl-for-property form prop) + (syntax-parse form + #:literals (let-values letrec-values #%plain-app + letrec-syntaxes+values) + [stx + #:when (syntax-property form prop) + (list form)] + [(let-values (b ...) + body) + (trawl-for-property #'body prop)] + [(letrec-values (b ...) + body) + (trawl-for-property #'body prop)] + [(letrec-syntaxes+values (sb ...) (vb ...) + body) + (trawl-for-property #'body prop)] + [(#%plain-app e ...) + (apply append (map (λ (stx) (trawl-for-property stx prop)) + (syntax->list #'(e ...))))] + [(#%plain-lambda (x ...) e ...) + (apply append (map (λ (stx) (trawl-for-property stx prop)) + (syntax->list #'(e ...))))] + [_ '()])) + +;; fixup-method-type : Function Type -> Function +;; Fix up a method's arity from a regular function type +(define (fixup-method-type type self-type) + (match type + [(Function: (list arrs ...)) + (define fixed-arrs + (for/list ([arr arrs]) + (match-define (arr: doms rng rest drest kws) arr) + (make-arr (cons self-type doms) rng rest drest kws))) + (make-Function fixed-arrs)] + [_ (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) + (syntax-parse stx + #:literals (let-values #%plain-lambda) + [(let-values ([(meth-name:id) + (#%plain-lambda (self-param:id id:id ...) + body ...)]) + m) + (define annotated-self-param + (type-ascription-property #'self-param self-type)) + #`(let-values ([(meth-name) + (#%plain-lambda (#,annotated-self-param id ...) + body ...)]) + m)] + [_ (tc-error "annotate-method: internal error")])) + +;; Set Set String -> Void +;; check that all the required names are actually present +(define (check-exists actual required msg) + (define missing + (for/or ([m (in-set required)]) + (and (not (set-member? actual m)) m))) + (when missing + ;; FIXME: make this a delayed error? Do it for every single + ;; name separately? + (tc-error/expr "class definition missing ~a ~a" msg missing))) + +;; Set Set String -> Void +;; check that names are absent when they should be +(define (check-absent actual should-be-absent msg) + (define present + (for/or ([m (in-set should-be-absent)]) + (and (set-member? actual m) m))) + (when present + (tc-error/expr "superclass defines conflicting ~a ~a" + msg present))) + +;; check-no-extra : Set Set -> Void +;; check that the actual names don't include names not in the +;; expected type (i.e., the names must exactly match up) +(define (check-no-extra actual expected) + (printf "actual : ~a expected : ~a~n" actual expected) + (unless (subset? actual expected) + ;; FIXME: better error reporting here + (tc-error/expr "class defines names not in expected type"))) + +;; I wish I could write this +#; +(module+ test + (check-equal? (fixup-method-type (parse-type #'(Integer -> Integer))) + (parse-type #'(Any Integer -> Integer)))) + diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/signatures.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/signatures.rkt index 3efa697b..32de3f63 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/signatures.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/signatures.rkt @@ -19,6 +19,10 @@ [cond-contracted check-subforms/with-handlers (syntax? . -> . any)] [cond-contracted check-subforms/with-handlers/check (syntax? tc-results/c . -> . any)])) +(define-signature check-class^ + ;; FIXME: make sure this is correct + ([cond-contracted check-class (syntax? Type/c . -> . any)])) + (define-signature tc-if^ ([cond-contracted tc/if-twoarm ((syntax? syntax? syntax?) (tc-results/c) . ->* . tc-results/c)])) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt index 10880f58..a54d1c5c 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/tc-expr-unit.rkt @@ -21,7 +21,8 @@ (for-label (only-in '#%paramz [parameterization-key pz:pk]) (only-in racket/private/class-internal find-method/who))) -(import tc-if^ tc-lambda^ tc-app^ tc-let^ tc-send^ check-subforms^ tc-literal^) +(import tc-if^ tc-lambda^ tc-app^ tc-let^ tc-send^ check-subforms^ tc-literal^ + check-class^) (export tc-expr^) (define-literal-set tc-expr-literals #:for-label @@ -184,6 +185,14 @@ (int-err "bad form input to tc-expr: ~a" form)) (syntax-parse form #:literal-sets (kernel-literals tc-expr-literals) + [stx + ;; a class: generated class + #:when (syntax-property form 'tr:class) + ;; use internal TR forms to hide information obtained + ;; at the class: level so that inits, fields, and method + ;; presence/absence can be checked immediately here + (check-class form expected) + expected] [stx:exn-handlers^ (register-ignored! form) (check-subforms/with-handlers/check form expected)] diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/typechecker.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/typechecker.rkt index 00a73420..c88c0e5c 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/typechecker.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/typechecker.rkt @@ -9,10 +9,12 @@ "tc-let-unit.rkt" "tc-apply.rkt" "tc-literal.rkt" "tc-send.rkt" - "tc-expr-unit.rkt" "check-subforms-unit.rkt") + "tc-expr-unit.rkt" "check-subforms-unit.rkt" + "check-class-unit.rkt") (provide-signature-elements tc-expr^ check-subforms^ tc-literal^) (define-values/invoke-unit/infer (link tc-if@ tc-lambda@ tc-app-combined@ tc-let@ tc-expr@ - tc-send@ check-subforms@ tc-apply@ tc-literal@)) + tc-send@ check-subforms@ tc-apply@ tc-literal@ + check-class@))