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
This commit is contained in:
Asumu Takikawa
parent
744c8593d6
commit
bc07b8b140
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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<Id>)
|
||||
;;
|
||||
;; 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<Clause> -> Hash<Identifier, Names>
|
||||
;; 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)))
|
||||
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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<Type> 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<Syntax>
|
||||
;; 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<Symbol> Set<Symbol> 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<Symbol> Set<Symbol> 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<Symbol> Set<Symbol> -> 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))))
|
||||
|
||||
|
|
@ -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)]))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)]
|
||||
|
|
|
|||
|
|
@ -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@))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user