Add support for separate augment/pubment interfaces
Now a class may have a pubment method that has a different type for being directly called and for being specialized for inner calls. This is actually necessary to type-check interesting uses of pubment/augment. Note that if a class does not provide a type annotation for the augmentation interface, it will be assumed to be the same as the pubment type. original commit: 8ca8eb164205df1850ce677d3e37053712565ed8
This commit is contained in:
Asumu Takikawa
parent
bd47f1e634
commit
3022f91b48
|
|
@ -28,17 +28,21 @@
|
|||
;; for use in ~literal clauses
|
||||
class-internal
|
||||
optional-init
|
||||
private-field)
|
||||
private-field
|
||||
:-augment)
|
||||
|
||||
;; give it a binding, but it shouldn't be used directly
|
||||
(define-syntax (class-internal stx)
|
||||
(raise-syntax-error "should only be used internally"))
|
||||
(raise-syntax-error 'class "should only be used internally"))
|
||||
|
||||
(define-syntax (optional-init stx)
|
||||
(raise-syntax-error "should only be used internally"))
|
||||
(raise-syntax-error 'class "should only be used internally"))
|
||||
|
||||
(define-syntax (private-field stx)
|
||||
(raise-syntax-error "should only be used internally"))
|
||||
(raise-syntax-error 'class "should only be used internally"))
|
||||
|
||||
(define-syntax (:-augment stx)
|
||||
(raise-syntax-error 'class "should only be used internally"))
|
||||
|
||||
(begin-for-syntax
|
||||
(module+ test (require rackunit))
|
||||
|
|
@ -47,6 +51,7 @@
|
|||
(define stop-forms
|
||||
(append (kernel-form-identifier-list)
|
||||
(list
|
||||
(quote-syntax :)
|
||||
(quote-syntax #%app)
|
||||
(quote-syntax lambda)
|
||||
(quote-syntax init)
|
||||
|
|
@ -344,7 +349,7 @@
|
|||
([content contents])
|
||||
(define stx (non-clause-stx content))
|
||||
(syntax-parse stx
|
||||
#:literals (define-values super-new)
|
||||
#:literals (: define-values super-new)
|
||||
;; if it's a method definition for a declared method, then
|
||||
;; mark it as something to type-check
|
||||
[(define-values (id) . rst)
|
||||
|
|
@ -365,6 +370,15 @@
|
|||
(append rest-top (list content))
|
||||
(append (syntax->list #'(id ...))
|
||||
private-fields))]
|
||||
;; special : annotation for augment interface
|
||||
[(: name:id type:expr #:augment augment-type:expr)
|
||||
(define new-clause
|
||||
(non-clause #'(quote-syntax (:-augment name augment-type))))
|
||||
(define plain-annotation
|
||||
(non-clause (syntax/loc stx (: name type))))
|
||||
(values methods
|
||||
(append rest-top (list plain-annotation new-clause))
|
||||
private-fields)]
|
||||
;; Identify super-new for the benefit of the type checker
|
||||
[(super-new [init-id init-expr] ...)
|
||||
(define new-non-clause
|
||||
|
|
|
|||
|
|
@ -631,11 +631,14 @@
|
|||
(define merged-augments (append checked-super-augments checked-augments))
|
||||
|
||||
;; make sure augments and methods are disjoint
|
||||
(define maybe-dup (check-duplicate (append (dict-keys merged-methods)
|
||||
(dict-keys merged-augments))))
|
||||
(when maybe-dup
|
||||
(tc-error (~a "method name " maybe-dup " conflicts with"
|
||||
" another method name or augmentable method name")))
|
||||
(define maybe-dup-method (check-duplicate (dict-keys merged-methods)))
|
||||
(when maybe-dup-method
|
||||
(tc-error (~a "method name " maybe-dup-method " conflicts with"
|
||||
" another method name")))
|
||||
(define maybe-dup-augment (check-duplicate (dict-keys merged-augments)))
|
||||
(when maybe-dup-augment
|
||||
(tc-error (~a "augmentable method name " maybe-dup-augment " conflicts with"
|
||||
" another augmentable method name")))
|
||||
|
||||
(values (or row-var super-row-var) merged-fields
|
||||
merged-methods merged-augments))
|
||||
|
|
|
|||
|
|
@ -260,7 +260,14 @@
|
|||
(values internal external)))
|
||||
;; trawl the body for top-level expressions
|
||||
(define top-level-exprs (trawl-for-property #'cls.make-methods 'tr:class:top-level))
|
||||
(define annotation-table (register-annotations top-level-exprs))
|
||||
;; 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))
|
||||
|
|
@ -286,6 +293,7 @@
|
|||
(infer-self-type super-row
|
||||
expected
|
||||
annotation-table
|
||||
augment-annotation-table
|
||||
optional-inits
|
||||
internal-external-mapping
|
||||
remaining-super-inits
|
||||
|
|
@ -358,20 +366,20 @@
|
|||
(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 internal-external-mapping meth-stxs methods self-type
|
||||
#:filter this%-overridable-names)))
|
||||
(define checked-pubment-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 internal-external-mapping meth-stxs augments self-type
|
||||
#:filter this%-augmentable-names)))
|
||||
(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-pubment-types))
|
||||
(merge-types self-type checked-method-types checked-augment-types))
|
||||
(check-method-presence-and-absence
|
||||
expected
|
||||
this%-init-names this%-field-names
|
||||
|
|
@ -413,13 +421,15 @@
|
|||
(dict-keys remaining-super-inits))
|
||||
exp-init-names
|
||||
"initialization argument")
|
||||
(check-same (set-union this%-public-names super-method-names)
|
||||
(check-same (set-union this%-public-names this%-pubment-names
|
||||
super-method-names)
|
||||
exp-method-names
|
||||
"public method")
|
||||
(check-same (set-union this%-field-names super-field-names)
|
||||
exp-field-names
|
||||
"public field")
|
||||
(check-same (set-union this%-pubment-names super-augment-names)
|
||||
(check-same (set-union this%-pubment-names this%-augment-names
|
||||
super-augment-names)
|
||||
exp-augment-names
|
||||
"public augmentable method")
|
||||
(check-same optional-external exp-optional-inits
|
||||
|
|
@ -442,7 +452,7 @@
|
|||
;; Given a self object type, construct the real class type based on
|
||||
;; new information found from type-checking. Only used when an expected
|
||||
;; type was not provided.
|
||||
(define (merge-types self-type method-types pubment-types)
|
||||
(define (merge-types self-type method-types augment-types)
|
||||
(match-define
|
||||
(Instance:
|
||||
(and class-type
|
||||
|
|
@ -454,12 +464,15 @@
|
|||
(define old-type (dict-ref methods name #f))
|
||||
;; sanity check, to ensure that the actual method type
|
||||
;; is as precise as the annotated type
|
||||
;; FIXME: should this be a type error and not internal?
|
||||
(when (and old-type (not (subtype (car type) (car old-type))))
|
||||
(int-err "merge-types: actual type not a subtype of annotated type"))
|
||||
(int-err (~a "merge-types: actual type ~a not"
|
||||
" a subtype of annotated type ~a")
|
||||
(car type) (car old-type)))
|
||||
(dict-set methods name type)))
|
||||
(make-Class row-var inits fields
|
||||
(make-new-methods methods method-types)
|
||||
(make-new-methods augments pubment-types)))
|
||||
(make-new-methods augments augment-types)))
|
||||
|
||||
;; local-tables->lexical-env : Dict<Symbol, Symbol>
|
||||
;; LocalMapping NameTypeDict Names
|
||||
|
|
@ -585,7 +598,7 @@
|
|||
(define super-call-types
|
||||
(make-private-like-types override-names super-types))
|
||||
(define pubment-types
|
||||
(make-private-like-types pubment-names augments))
|
||||
(make-private-like-types pubment-names methods))
|
||||
|
||||
(define init-types
|
||||
(for/list ([i (in-set init-names)])
|
||||
|
|
@ -627,12 +640,11 @@
|
|||
init-types
|
||||
(list self-type (make-Univ)))))
|
||||
|
||||
;; check-methods : Listof<Syntax> Dict<Symbol, Symbol> Dict Type
|
||||
;; check-methods : Listof<Symbol> Listof<Syntax> Dict<Symbol, Symbol> Dict Type
|
||||
;; -> Dict<Symbol, Type>
|
||||
;; Type-check the methods inside of a class
|
||||
(define (check-methods internal-external-mapping
|
||||
meths methods self-type
|
||||
#:filter [filter #f])
|
||||
(define (check-methods names-to-check internal-external-mapping
|
||||
meths methods self-type)
|
||||
(for/fold ([checked '()])
|
||||
([meth meths])
|
||||
(define method-name (syntax-property meth 'tr:class:method))
|
||||
|
|
@ -641,7 +653,8 @@
|
|||
(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)))
|
||||
(not (equal? (car maybe-expected) top-func))
|
||||
(set-member? names-to-check external-name))
|
||||
(define pre-method-type (car maybe-expected))
|
||||
(define method-type
|
||||
(function->method pre-method-type self-type))
|
||||
|
|
@ -652,7 +665,7 @@
|
|||
;; Only try to type-check if these names are in the
|
||||
;; filter when it's provided. This allows us to, say, only
|
||||
;; type-check pubments/augments.
|
||||
[(and filter (set-member? filter external-name))
|
||||
[(set-member? names-to-check external-name)
|
||||
(cons (list external-name
|
||||
(method->function (tc-expr/t meth)))
|
||||
checked)]
|
||||
|
|
@ -945,13 +958,26 @@
|
|||
(recur-on-all #'(e ...))]
|
||||
[_ '()]))
|
||||
|
||||
;; register-annotations : Listof<Syntax> -> Dict<Symbol, Type>
|
||||
;; register-annotations : Listof<Syntax>
|
||||
;; -> Dict<Symbol, Type>, Dict<Symbol, Type>
|
||||
;; Find : annotations and register them, error if duplicates are found
|
||||
;; TODO: support `define-type`?
|
||||
(define (register-annotations stxs)
|
||||
(for/fold ([table #hash()]) ([stx stxs])
|
||||
;; check if the key is duplicated and return the new table
|
||||
;; (erroring if it is a duplicate)
|
||||
(define (check-duplicate table name type)
|
||||
(cond [(and (hash-has-key? table name)
|
||||
(not (equal? (hash-ref table name) type)))
|
||||
(tc-error/expr
|
||||
#:stx #'name
|
||||
"Duplicate type annotation of ~a for ~a, previous was ~a"
|
||||
type name (hash-ref table name))
|
||||
table]
|
||||
[else (hash-set table name type)]))
|
||||
(for/fold ([table #hash()] [augment-table #hash()])
|
||||
([stx stxs])
|
||||
(syntax-parse stx
|
||||
#:literals (let-values begin quote-syntax :-internal
|
||||
#:literals (let-values begin quote-syntax :-internal :-augment
|
||||
#%plain-app values void)
|
||||
[(let-values ((()
|
||||
(begin
|
||||
|
|
@ -960,30 +986,48 @@
|
|||
(#%plain-app void))
|
||||
(define name (syntax-e #'name-stx))
|
||||
(define type (parse-type #'type-stx))
|
||||
(cond [(and (hash-has-key? table name)
|
||||
(not (equal? (hash-ref table name)
|
||||
type)))
|
||||
(tc-error/expr
|
||||
#:stx #'name
|
||||
"Duplicate type annotation of ~a for ~a, previous was ~a"
|
||||
type name (hash-ref table name))
|
||||
table]
|
||||
[else (hash-set table name type)])]
|
||||
[_ table])))
|
||||
(values (check-duplicate table name type) augment-table)]
|
||||
[(quote-syntax (:-augment name-stx:id type-stx))
|
||||
(define name (syntax-e #'name-stx))
|
||||
(define type (parse-type #'type-stx))
|
||||
(values table (check-duplicate augment-table name type))]
|
||||
[_ (values table augment-table)])))
|
||||
|
||||
;; infer-self-type : RowVar Class Dict<Symbol, Type> Set<Symbol> Dict<Symbol, Symbol>
|
||||
;; setup-pubment-defaults : Listof<Symbol> ->
|
||||
;; Dict<Symbol, Type> Dict<Symbol, Type> ->
|
||||
;; Dict<Symbol, Type> Dict<Symbol, Type>
|
||||
;; this does a second pass through the type annotations and adds
|
||||
;; the pubment types as default augment types if an augment type
|
||||
;; was not already provided
|
||||
(define ((setup-pubment-defaults pubment-names)
|
||||
annotations augment-annotations)
|
||||
(for/fold ([annotations annotations]
|
||||
[augment-annotations augment-annotations])
|
||||
([name pubment-names])
|
||||
(cond [(and (not (dict-has-key? augment-annotations name))
|
||||
(dict-has-key? annotations name))
|
||||
(values annotations
|
||||
(dict-set augment-annotations name
|
||||
(dict-ref annotations name)))]
|
||||
[else (values annotations augment-annotations)])))
|
||||
|
||||
;; infer-self-type : RowVar Class Dict<Symbol, Type> Dict<Symbol, Type>
|
||||
;; Set<Symbol> Dict<Symbol, Symbol>
|
||||
;; Inits Fields Methods
|
||||
;; Set<Symbol> * 4 -> Type
|
||||
;; Construct a self object type based on all type annotations
|
||||
;; and the expected type
|
||||
(define (infer-self-type super-row
|
||||
expected
|
||||
annotation-table optional-inits
|
||||
annotation-table augment-annotation-table
|
||||
optional-inits
|
||||
internal-external-mapping
|
||||
super-inits super-fields super-methods
|
||||
super-augments
|
||||
inits fields publics augments)
|
||||
(define (make-type-dict names supers maybe-expected [inits? #f]
|
||||
inits fields publics pubments)
|
||||
(define (make-type-dict names supers maybe-expected
|
||||
#:inits [inits? #f]
|
||||
#:annotations-from [annotation-table annotation-table]
|
||||
#:default-type [default-type Univ])
|
||||
(for/fold ([type-dict supers])
|
||||
([name names])
|
||||
|
|
@ -1009,13 +1053,16 @@
|
|||
[(Class: _ inits fields publics augments)
|
||||
(values inits fields publics augments)]
|
||||
[_ (values #f #f #f #f)]))
|
||||
(define init-types (make-type-dict inits super-inits expected-inits #t))
|
||||
(define init-types (make-type-dict inits super-inits expected-inits
|
||||
#:inits #t))
|
||||
(define field-types (make-type-dict fields super-fields expected-fields))
|
||||
(define public-types (make-type-dict publics super-methods expected-publics
|
||||
(define public-types (make-type-dict (append publics pubments)
|
||||
super-methods expected-publics
|
||||
#:default-type top-func))
|
||||
(define augment-types (make-type-dict
|
||||
augments super-augments expected-augments
|
||||
#:default-type top-func))
|
||||
pubments super-augments expected-augments
|
||||
#:default-type top-func
|
||||
#:annotations-from augment-annotation-table))
|
||||
(make-Instance (make-Class super-row init-types field-types
|
||||
public-types augment-types)))
|
||||
|
||||
|
|
|
|||
|
|
@ -16,10 +16,10 @@
|
|||
(match rcvr-type
|
||||
[(tc-result1: (Instance: (? Mu? type)))
|
||||
(do-check (ret (make-Instance (unfold type))))]
|
||||
[(tc-result1: (Instance: (and c (Class: _ _ _ methods augments))))
|
||||
[(tc-result1: (Instance: (and c (Class: _ _ _ methods _))))
|
||||
(match (tc-expr method)
|
||||
[(tc-result1: (Value: (? symbol? s)))
|
||||
(let* ([ftype (cond [(assq s (append methods augments)) => cadr]
|
||||
(let* ([ftype (cond [(assq s methods) => cadr]
|
||||
[else (tc-error/expr "send: method ~a not understood by class ~a" s c)])]
|
||||
[retval (tc/funapp rcvr args (ret ftype) (stx-map tc-expr args) expected)])
|
||||
(add-typeof-expr form retval)
|
||||
|
|
|
|||
|
|
@ -212,9 +212,11 @@
|
|||
(check-duplicate (map first (attribute fields)))
|
||||
"duplicate field or init-field clause"
|
||||
#:fail-when
|
||||
(check-duplicate (map first (append (attribute methods)
|
||||
(attribute augments))))
|
||||
"duplicate method or augmentable method clause"))
|
||||
(check-duplicate (map first (attribute methods)))
|
||||
"duplicate method clause"
|
||||
#:fail-when
|
||||
(check-duplicate (map first (attribute augments)))
|
||||
"duplicate augment clause"))
|
||||
|
||||
;; Stx Stx Listof<Boolean> (Stx -> Type) -> Listof<(List Symbol Type Boolean)>
|
||||
;; Construct init entries for a dictionary for the class type
|
||||
|
|
@ -237,51 +239,55 @@
|
|||
#:attributes (init-entries field-entries
|
||||
method-entries augment-entries)
|
||||
#:literals (init init-field field augment)
|
||||
(pattern (~or (init init-clause:init-type ...)
|
||||
(init-field init-field-clause:init-type ...)
|
||||
(field field-clause:field-or-method-type ...)
|
||||
(augment augment-clause:field-or-method-type ...)
|
||||
method-clause:field-or-method-type)
|
||||
(pattern (init init-clause:init-type ...)
|
||||
#:attr init-entries
|
||||
(append (if (attribute init-clause)
|
||||
(make-init-entries
|
||||
#'(init-clause.label ...)
|
||||
#'(init-clause.type ...)
|
||||
(attribute init-clause.optional?)
|
||||
parse-type)
|
||||
null)
|
||||
(if (attribute init-field-clause)
|
||||
(make-init-entries
|
||||
#'(init-field-clause.label ...)
|
||||
#'(init-field-clause.type ...)
|
||||
(attribute init-field-clause.optional?)
|
||||
parse-type)
|
||||
null))
|
||||
(make-init-entries
|
||||
#'(init-clause.label ...)
|
||||
#'(init-clause.type ...)
|
||||
(attribute init-clause.optional?)
|
||||
parse-type)
|
||||
#:attr field-entries null
|
||||
#:attr method-entries null
|
||||
#:attr augment-entries null)
|
||||
(pattern (init-field init-field-clause:init-type ...)
|
||||
#:attr init-entries
|
||||
(make-init-entries
|
||||
#'(init-field-clause.label ...)
|
||||
#'(init-field-clause.type ...)
|
||||
(attribute init-field-clause.optional?)
|
||||
parse-type)
|
||||
#:attr field-entries
|
||||
(append (if (attribute field-clause)
|
||||
(make-field/augment-entries
|
||||
#'(field-clause.label ...)
|
||||
#'(field-clause.type ...)
|
||||
parse-type)
|
||||
null)
|
||||
(if (attribute init-field-clause)
|
||||
(make-field/augment-entries
|
||||
#'(init-field-clause.label ...)
|
||||
#'(init-field-clause.type ...)
|
||||
parse-type)
|
||||
null))
|
||||
#:attr method-entries
|
||||
(if (attribute method-clause)
|
||||
(list (list (syntax-e #'method-clause.label)
|
||||
(parse-type #'method-clause.type)))
|
||||
null)
|
||||
(make-field/augment-entries
|
||||
#'(init-field-clause.label ...)
|
||||
#'(init-field-clause.type ...)
|
||||
parse-type)
|
||||
#:attr method-entries null
|
||||
#:attr augment-entries null)
|
||||
(pattern (field field-clause:field-or-method-type ...)
|
||||
#:attr init-entries null
|
||||
#:attr field-entries
|
||||
(make-field/augment-entries
|
||||
#'(field-clause.label ...)
|
||||
#'(field-clause.type ...)
|
||||
parse-type)
|
||||
#:attr method-entries null
|
||||
#:attr augment-entries null)
|
||||
(pattern (augment augment-clause:field-or-method-type ...)
|
||||
#:attr init-entries null
|
||||
#:attr field-entries null
|
||||
#:attr method-entries null
|
||||
#:attr augment-entries
|
||||
(if (attribute augment-clause)
|
||||
(make-field/augment-entries
|
||||
#'(augment-clause.label ...)
|
||||
#'(augment-clause.type ...)
|
||||
parse-type)
|
||||
null)))
|
||||
(make-field/augment-entries
|
||||
#'(augment-clause.label ...)
|
||||
#'(augment-clause.type ...)
|
||||
parse-type))
|
||||
(pattern method-clause:field-or-method-type
|
||||
#:attr init-entries null
|
||||
#:attr field-entries null
|
||||
#:attr method-entries
|
||||
(list (list (syntax-e #'method-clause.label)
|
||||
(parse-type #'method-clause.type)))
|
||||
#:attr augment-entries null))
|
||||
|
||||
(define-syntax-class init-type
|
||||
#:description "Initialization argument label and type"
|
||||
|
|
|
|||
|
|
@ -927,8 +927,50 @@
|
|||
(+ 1 x))))
|
||||
(send (new c%) m 0))
|
||||
|
||||
;; make sure augment type is reflected in class type
|
||||
(check-ok
|
||||
(: c% (Class (augment [m (String -> Integer)])
|
||||
[m (Integer -> Integer)]))
|
||||
(define c%
|
||||
(class object% (super-new)
|
||||
(: m (Integer -> Integer)
|
||||
#:augment (String -> Integer))
|
||||
(define/pubment (m x) x))))
|
||||
|
||||
;; pubment with different augment type
|
||||
(check-ok
|
||||
(define c%
|
||||
(class object%
|
||||
(super-new)
|
||||
(: m (Integer -> Integer)
|
||||
#:augment (String -> String))
|
||||
(define/pubment (m x)
|
||||
(inner "" m "foo") 0)))
|
||||
(define d%
|
||||
(class c%
|
||||
(super-new)
|
||||
(define/augment (m x)
|
||||
(string-append x "bar"))))
|
||||
(send (new c%) m 0))
|
||||
|
||||
;; fail, bad inner argument
|
||||
(check-err #:exn #rx"Expected String, but got Integer"
|
||||
(define c%
|
||||
(class object%
|
||||
(super-new)
|
||||
(: m (Integer -> Integer)
|
||||
#:augment (String -> String))
|
||||
(define/pubment (m x)
|
||||
(inner "" m x) 0)))
|
||||
(define d%
|
||||
(class c%
|
||||
(super-new)
|
||||
(define/augment (m x)
|
||||
(string-append x "bar"))))
|
||||
(send (new c%) m 0))
|
||||
|
||||
;; Fail, bad inner default
|
||||
(check-err
|
||||
(check-err #:exn #rx"Expected Integer, but got String"
|
||||
(define c%
|
||||
(class object%
|
||||
(super-new)
|
||||
|
|
@ -937,7 +979,7 @@
|
|||
(inner "foo" m x)))))
|
||||
|
||||
;; Fail, wrong number of arguments to inner
|
||||
(check-err
|
||||
(check-err #:exn #rx"Wrong number of arguments, expected 2"
|
||||
(define c%
|
||||
(class object%
|
||||
(super-new)
|
||||
|
|
@ -946,7 +988,7 @@
|
|||
(inner 3 m)))))
|
||||
|
||||
;; Fail, bad augment type
|
||||
(check-err
|
||||
(check-err #:exn #rx"Expected Integer, but got String"
|
||||
(define c%
|
||||
(class object%
|
||||
(super-new)
|
||||
|
|
@ -959,7 +1001,7 @@
|
|||
(define/augment (m x) "bad type"))))
|
||||
|
||||
;; Fail, cannot augment non-augmentable method
|
||||
(check-err
|
||||
(check-err #:exn #rx"superclass missing augmentable method m"
|
||||
(define c%
|
||||
(class object%
|
||||
(super-new)
|
||||
|
|
@ -982,7 +1024,8 @@
|
|||
|
||||
;; Pubment with expected class type
|
||||
(check-ok
|
||||
(: c% (Class (augment [m (Natural -> Natural)])))
|
||||
(: c% (Class [m (Natural -> Natural)]
|
||||
(augment [m (Natural -> Natural)])))
|
||||
(define c%
|
||||
(class object%
|
||||
(super-new)
|
||||
|
|
|
|||
|
|
@ -218,6 +218,8 @@
|
|||
(make-Class #f null null null `((m ,(t:-> N N))))]
|
||||
[(Class (augment [m (Number -> Number)]) (field [x Number]))
|
||||
(make-Class #f null `((x ,-Number)) null `((m ,(t:-> N N))))]
|
||||
[(Class (augment [m (-> Number)]) [m (-> Number)])
|
||||
(make-Class #f null null `((m ,(t:-> N))) `((m ,(t:-> N))))]
|
||||
[FAIL (Class foobar)]
|
||||
[FAIL (Class [x UNBOUND])]
|
||||
[FAIL (Class [x Number #:random-keyword])]
|
||||
|
|
@ -229,8 +231,9 @@
|
|||
[FAIL (Class (init [x Number]) (init [x Number]))]
|
||||
[FAIL (Class (init [x Number]) (init-field [x Number]))]
|
||||
[FAIL (Class (field [x Number]) (init-field [x Number]))]
|
||||
[FAIL (Class (augment [x (-> Number)]) [x (-> Number)])]
|
||||
[FAIL (Class (augment [x (-> Number)] [x (-> String)]))]
|
||||
[FAIL (Class (augment [m (-> Number)] [m (-> Number)]))]
|
||||
[FAIL (Class (augment [m (-> Number)]) (augment [m (-> Number)]))]
|
||||
[FAIL (Class [m (-> Number)] [m (-> Number)])]
|
||||
;; test #:row-var
|
||||
[(All (r #:row) (Class #:row-var r))
|
||||
(make-PolyRow (list 'r)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user