If no annotations are present, assume Any or Procedure
Note that for methods, if the type is annotated as Procedure, TR will try to find a more precise type and use that instead.
This commit is contained in:
parent
98b49deb76
commit
27a7322033
|
@ -454,9 +454,10 @@
|
||||||
(for/fold ([methods methods])
|
(for/fold ([methods methods])
|
||||||
([(name type) (in-dict method-types)])
|
([(name type) (in-dict method-types)])
|
||||||
(define old-type (dict-ref methods name #f))
|
(define old-type (dict-ref methods name #f))
|
||||||
;; sanity check
|
;; sanity check, to ensure that the actual method type
|
||||||
(when (and old-type (not (equal? old-type type)))
|
;; is as precise as the annotated type
|
||||||
(tc-error "merge-types: internal error"))
|
(when (and old-type (not (subtype (car type) (car old-type))))
|
||||||
|
(int-err "merge-types: actual type not a subtype of annotated type"))
|
||||||
(dict-set methods name type)))
|
(dict-set methods name type)))
|
||||||
(make-Class #f inits fields
|
(make-Class #f inits fields
|
||||||
(make-new-methods methods method-types)
|
(make-new-methods methods method-types)
|
||||||
|
@ -518,9 +519,12 @@
|
||||||
(define external (dict-ref internal-external-mapping m))
|
(define external (dict-ref internal-external-mapping m))
|
||||||
(define maybe-type (dict-ref type-map external #f))
|
(define maybe-type (dict-ref type-map external #f))
|
||||||
(->* (list (make-Univ))
|
(->* (list (make-Univ))
|
||||||
(cond [(and maybe-type (not inner?))
|
(cond [(and maybe-type
|
||||||
|
(not (equal? (car maybe-type) top-func))
|
||||||
|
(not inner?))
|
||||||
(fixup-method-type (car maybe-type) self-type)]
|
(fixup-method-type (car maybe-type) self-type)]
|
||||||
[maybe-type
|
[(and maybe-type
|
||||||
|
(not (equal? (car maybe-type) top-func)))
|
||||||
(Un (-val #f)
|
(Un (-val #f)
|
||||||
(fixup-method-type (car maybe-type) self-type))]
|
(fixup-method-type (car maybe-type) self-type))]
|
||||||
[else (make-Univ)]))))
|
[else (make-Univ)]))))
|
||||||
|
@ -618,7 +622,10 @@
|
||||||
(define method-name (syntax-property meth 'tr:class:method))
|
(define method-name (syntax-property meth 'tr:class:method))
|
||||||
(define external-name (dict-ref internal-external-mapping method-name #f))
|
(define external-name (dict-ref internal-external-mapping method-name #f))
|
||||||
(define maybe-expected (and external-name (dict-ref methods external-name #f)))
|
(define maybe-expected (and external-name (dict-ref methods external-name #f)))
|
||||||
(cond [maybe-expected
|
(cond [(and maybe-expected
|
||||||
|
;; fall back to tc-expr/t if the annotated type
|
||||||
|
;; was the default type (Procedure)
|
||||||
|
(not (equal? (car maybe-expected) top-func)))
|
||||||
(define pre-method-type (car maybe-expected))
|
(define pre-method-type (car maybe-expected))
|
||||||
(define method-type
|
(define method-type
|
||||||
(fixup-method-type pre-method-type self-type))
|
(fixup-method-type pre-method-type self-type))
|
||||||
|
@ -946,7 +953,8 @@
|
||||||
super-inits super-fields super-methods
|
super-inits super-fields super-methods
|
||||||
super-augments
|
super-augments
|
||||||
inits fields publics augments)
|
inits fields publics augments)
|
||||||
(define (make-type-dict names supers [inits? #f])
|
(define (make-type-dict names supers [inits? #f]
|
||||||
|
#:default-type [default-type Univ])
|
||||||
(for/fold ([type-dict supers])
|
(for/fold ([type-dict supers])
|
||||||
([name names])
|
([name names])
|
||||||
(define external (dict-ref internal-external-mapping name))
|
(define external (dict-ref internal-external-mapping name))
|
||||||
|
@ -957,11 +965,17 @@
|
||||||
(list type (set-member? optional-inits name))
|
(list type (set-member? optional-inits name))
|
||||||
(list type)))
|
(list type)))
|
||||||
(dict-set type-dict external entry))]
|
(dict-set type-dict external entry))]
|
||||||
[else type-dict])))
|
[else
|
||||||
|
(dict-set type-dict external
|
||||||
|
(if inits?
|
||||||
|
(list default-type (set-member? optional-inits name))
|
||||||
|
(list default-type)))])))
|
||||||
(define init-types (make-type-dict inits super-inits #t))
|
(define init-types (make-type-dict inits super-inits #t))
|
||||||
(define field-types (make-type-dict fields super-fields))
|
(define field-types (make-type-dict fields super-fields))
|
||||||
(define public-types (make-type-dict publics super-methods))
|
(define public-types (make-type-dict publics super-methods
|
||||||
(define augment-types (make-type-dict augments super-augments))
|
#:default-type top-func))
|
||||||
|
(define augment-types (make-type-dict augments super-augments
|
||||||
|
#:default-type top-func))
|
||||||
(make-Instance (make-Class #f init-types field-types
|
(make-Instance (make-Class #f init-types field-types
|
||||||
public-types augment-types)))
|
public-types augment-types)))
|
||||||
|
|
||||||
|
@ -971,7 +985,10 @@
|
||||||
(match type
|
(match type
|
||||||
[(Function: (list arrs ...))
|
[(Function: (list arrs ...))
|
||||||
(define fixed-arrs
|
(define fixed-arrs
|
||||||
(for/list ([arr arrs])
|
(for/list ([arr arrs]
|
||||||
|
;; ignore top-arr, since the arity cannot
|
||||||
|
;; be sensibly modified in that case
|
||||||
|
#:when (arr? arr))
|
||||||
(match-define (arr: doms rng rest drest kws) arr)
|
(match-define (arr: doms rng rest drest kws) arr)
|
||||||
(make-arr (cons self-type doms) rng rest drest kws)))
|
(make-arr (cons self-type doms) rng rest drest kws)))
|
||||||
(make-Function fixed-arrs)]
|
(make-Function fixed-arrs)]
|
||||||
|
|
|
@ -210,17 +210,14 @@
|
||||||
(define c% (class object% (super-new)
|
(define c% (class object% (super-new)
|
||||||
(field [str "foo"] [x 0]))))
|
(field [str "foo"] [x 0]))))
|
||||||
|
|
||||||
;; FIXME: for the following two tests, we could improve
|
;; test that an init with no annotation still type-checks
|
||||||
;; things by either figuring out the init or field
|
;; (though it will have the Any type)
|
||||||
;; type when a default expr is provided. Otherwise,
|
(check-ok
|
||||||
;; we should still provide a better error message.
|
|
||||||
;;
|
|
||||||
;; fails, init with no type annotation
|
|
||||||
(check-err #:exn #rx"x has no type annotation"
|
|
||||||
(define c% (class object% (super-new) (init x))))
|
(define c% (class object% (super-new) (init x))))
|
||||||
|
|
||||||
;; fails, field with no type annotation
|
;; test that a field with no annotation still type-checks
|
||||||
(check-err #:exn #rx"unexpected public field x"
|
;; (though it will have the Any type)
|
||||||
|
(check-ok
|
||||||
(define c% (class object% (super-new) (field [x 0]))))
|
(define c% (class object% (super-new) (field [x 0]))))
|
||||||
|
|
||||||
;; Mixin on classes without row polymorphism
|
;; Mixin on classes without row polymorphism
|
||||||
|
@ -750,7 +747,7 @@
|
||||||
|
|
||||||
;; fails, because the local call type is unknown
|
;; fails, because the local call type is unknown
|
||||||
;; and is assumed to be Any
|
;; and is assumed to be Any
|
||||||
(check-err
|
(check-err #:exn #rx"since it is not a function type"
|
||||||
(class object% (super-new)
|
(class object% (super-new)
|
||||||
(define/public (m) (n))
|
(define/public (m) (n))
|
||||||
(define/public (n x) 0)))
|
(define/public (n x) 0)))
|
||||||
|
|
Loading…
Reference in New Issue
Block a user