Add augride, which is like augment but enables the contract writer to give
subclasses an idea of whether a method can be augmented (augment) or whether a method augmentation can be overridden (augride). svn: r18240
This commit is contained in:
Stevie Strickland
parent
5df617e4d4
commit
ffa34e1f7d
|
|
@ -2485,12 +2485,23 @@
|
|||
(when (eq? flag 'final)
|
||||
(failed "method ~a is final" m)))))
|
||||
(for ([m (class/c-augments ctc)])
|
||||
(let ([index (hash-ref method-ht m #f)])
|
||||
(unless index
|
||||
(failed "no public method ~a" m))
|
||||
(let* ([vec (vector-ref beta-methods index)])
|
||||
(when (zero? (vector-length vec))
|
||||
(failed "method ~a has never been augmentable" m))
|
||||
(when (vector-ref vec (sub1 (vector-length vec)))
|
||||
(failed "method ~a is currently overrideable, not augmentable" m)))))
|
||||
(for ([m (class/c-augrides ctc)])
|
||||
(let ([index (hash-ref method-ht m #f)])
|
||||
(unless index
|
||||
(failed "no public method ~a" m))
|
||||
(let ([vec (vector-ref beta-methods index)])
|
||||
(when (zero? (vector-length vec))
|
||||
(failed "method ~a has never been augmentable" m)))))
|
||||
(failed "method ~a has never been augmentable" m))
|
||||
(unless (vector-ref vec (sub1 (vector-length vec)))
|
||||
(failed "method ~a is currently augmentable, not overrideable" m)))))
|
||||
(for ([s (class/c-supers ctc)])
|
||||
(let ([index (hash-ref method-ht s #f)])
|
||||
(unless index
|
||||
|
|
@ -2529,10 +2540,12 @@
|
|||
[dynamic-features
|
||||
(append (class/c-overrides ctc)
|
||||
(class/c-augments ctc)
|
||||
(class/c-augrides ctc)
|
||||
(class/c-inherits ctc))]
|
||||
[dynamic-contracts
|
||||
(append (class/c-override-contracts ctc)
|
||||
(class/c-augment-contracts ctc)
|
||||
(class/c-augride-contracts ctc)
|
||||
(class/c-inherit-contracts ctc))]
|
||||
[methods (if (null? (class/c-methods ctc))
|
||||
(class-methods cls)
|
||||
|
|
@ -2752,12 +2765,15 @@
|
|||
(vector-set! proj-vec old-idx
|
||||
(compose (vector-ref proj-vec old-idx) p))))))
|
||||
|
||||
;; For augment contracts, we both update the projection and go
|
||||
;; ahead and apply the projection to the last slot (which will
|
||||
;; For augment and augride contracts, we both update the projection
|
||||
;; and go ahead and apply the projection to the last slot (which will
|
||||
;; only be used by later classes).
|
||||
(unless (null? (class/c-augments ctc))
|
||||
(for ([m (in-list (class/c-augments ctc))]
|
||||
[c (in-list (class/c-augment-contracts ctc))])
|
||||
(unless (and (null? (class/c-augments ctc))
|
||||
(null? (class/c-augrides ctc)))
|
||||
(for ([m (in-list (append (class/c-augments ctc)
|
||||
(class/c-augrides ctc)))]
|
||||
[c (in-list (append (class/c-augment-contracts ctc)
|
||||
(class/c-augride-contracts ctc)))])
|
||||
(when c
|
||||
(let* ([i (hash-ref method-ht m)]
|
||||
[p ((contract-projection c) blame)]
|
||||
|
|
@ -2789,7 +2805,8 @@
|
|||
(methods method-contracts fields field-contracts
|
||||
inherits inherit-contracts inherit-fields inherit-field-contracts
|
||||
supers super-contracts inners inner-contracts
|
||||
overrides override-contracts augments augment-contracts)
|
||||
overrides override-contracts augments augment-contracts
|
||||
augrides augride-contracts)
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
|
|
@ -2824,7 +2841,8 @@
|
|||
(handle-optional 'super (class/c-supers ctc) (class/c-super-contracts ctc))
|
||||
(handle-optional 'inner (class/c-inners ctc) (class/c-inner-contracts ctc))
|
||||
(handle-optional 'override (class/c-overrides ctc) (class/c-override-contracts ctc))
|
||||
(handle-optional 'augment (class/c-augments ctc) (class/c-augment-contracts ctc))))))
|
||||
(handle-optional 'augment (class/c-augments ctc) (class/c-augment-contracts ctc))
|
||||
(handle-optional 'augride (class/c-augrides ctc) (class/c-augride-contracts ctc))))))
|
||||
#:first-order
|
||||
(λ (ctc)
|
||||
(λ (cls)
|
||||
|
|
@ -2851,7 +2869,7 @@
|
|||
(let-values ([(name ctc) (parse-name-ctc stx)])
|
||||
(values (cons name names) (cons ctc ctcs)))))
|
||||
(define (parse-spec stx)
|
||||
(syntax-case stx (field inherit inherit-field init super inner override augment)
|
||||
(syntax-case stx (field inherit inherit-field init super inner override augment augride)
|
||||
[(field f-spec ...)
|
||||
(let-values ([(names ctcs) (parse-names-ctcs #'(f-spec ...))])
|
||||
(hash-set! parsed-forms 'fields
|
||||
|
|
@ -2912,6 +2930,15 @@
|
|||
(append names (hash-ref parsed-forms 'augments null)))
|
||||
(hash-set! parsed-forms 'augment-contracts
|
||||
(append ctcs (hash-ref parsed-forms 'augment-contracts null)))))]
|
||||
[(augride a-spec ...)
|
||||
(begin
|
||||
(when object/c?
|
||||
(raise-syntax-error 'object/c "augride contract not allowed in object/c" stx))
|
||||
(let-values ([(names ctcs) (parse-names-ctcs #'(a-spec ...))])
|
||||
(hash-set! parsed-forms 'augrides
|
||||
(append names (hash-ref parsed-forms 'augrides null)))
|
||||
(hash-set! parsed-forms 'augride-contracts
|
||||
(append ctcs (hash-ref parsed-forms 'augride-contracts null)))))]
|
||||
[m-spec
|
||||
(let-values ([(name ctc1) (parse-name-ctc #'m-spec)])
|
||||
(hash-set! parsed-forms 'methods
|
||||
|
|
@ -2943,7 +2970,9 @@
|
|||
[overrides #`(list #,@(reverse (hash-ref parsed-forms 'overrides null)))]
|
||||
[override-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'override-contracts null)))]
|
||||
[augments #`(list #,@(reverse (hash-ref parsed-forms 'augments null)))]
|
||||
[augment-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augment-contracts null)))])
|
||||
[augment-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augment-contracts null)))]
|
||||
[augrides #`(list #,@(reverse (hash-ref parsed-forms 'augrides null)))]
|
||||
[augride-ctcs #`(list #,@(reverse (hash-ref parsed-forms 'augride-contracts null)))])
|
||||
(syntax/loc stx
|
||||
(make-class/c methods method-ctcs
|
||||
fields field-ctcs
|
||||
|
|
@ -2952,7 +2981,8 @@
|
|||
supers super-ctcs
|
||||
inners inner-ctcs
|
||||
overrides override-ctcs
|
||||
augments augment-ctcs))))]))
|
||||
augments augment-ctcs
|
||||
augrides augride-ctcs))))]))
|
||||
|
||||
(define (object/c-check-first-order ctc obj blame)
|
||||
(let/ec return
|
||||
|
|
|
|||
|
|
@ -1467,7 +1467,7 @@ resulting trait is the same as for @scheme[trait-sum], otherwise the
|
|||
@section{Object and Class Contracts}
|
||||
|
||||
@defform/subs[
|
||||
#:literals (field inherit inherit-field super inner override augment)
|
||||
#:literals (field inherit inherit-field super inner override augment augride)
|
||||
|
||||
(class/c member-spec ...)
|
||||
|
||||
|
|
@ -1541,10 +1541,12 @@ The internal contracts are as follows:
|
|||
@scheme[(method-id ...)]). This form can only be used if overriding the method in subclasses
|
||||
will change the entry point to the dynamic dispatch chain (i.e., the method has never been
|
||||
augmentable).}
|
||||
@item{A method contract, tagged with @scheme[augment], describes the behavior provided by
|
||||
the contracted class for @scheme[method-id] when called directly from subclasses. This form
|
||||
can only be used if the method has previously been augmentable, which means that no augmenting
|
||||
or overriding implementation will change the entry point to the dynamic dispatch chain.}
|
||||
@item{A method contract, tagged with either @scheme[augment] or @scheme[augride], describes the
|
||||
behavior provided by the contracted class for @scheme[method-id] when called directly from
|
||||
subclasses. These forms can only be used if the method has previously been augmentable, which
|
||||
means that no augmenting or overriding implementation will change the entry point to the
|
||||
dynamic dispatch chain. @scheme[augment] is used when subclasses can augment the method, and
|
||||
@scheme[augride] is used when subclasses can override the current augmentation.}
|
||||
]}
|
||||
|
||||
@defform/subs[
|
||||
|
|
|
|||
|
|
@ -4410,7 +4410,7 @@
|
|||
'pos
|
||||
'neg))
|
||||
|
||||
(test/spec-passed
|
||||
(test/pos-blame
|
||||
'class/c-first-order-augment-4
|
||||
'(contract (class/c (augment [m (-> any/c number? number?)]))
|
||||
(let ([c% (class object% (super-new) (define/pubment (m x) (inner x m x)))])
|
||||
|
|
@ -4431,7 +4431,7 @@
|
|||
'(contract (class/c (augment [m (-> any/c number? number?)]))
|
||||
(let* ([c% (class object% (super-new) (define/public (m x) (add1 x)))]
|
||||
[d% (class c% (super-new) (define/overment (m x) (+ (super m x) (inner x m x))))])
|
||||
(class d% (super-new) (define/augride (m x) x)))
|
||||
(class d% (super-new) (define/augment (m x) x)))
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
|
|
@ -4458,6 +4458,77 @@
|
|||
'neg)])
|
||||
(class c% (super-new) (inherit m))))
|
||||
|
||||
(test/pos-blame
|
||||
'class/c-first-order-augride-1
|
||||
'(contract (class/c (augride [m (-> any/c number? number?)]))
|
||||
object%
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(test/pos-blame
|
||||
'class/c-first-order-augride-2
|
||||
'(contract (class/c (augride [m (-> any/c number? number?)]))
|
||||
(class object% (super-new) (define/pubment (m x) (add1 x)))
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(test/pos-blame
|
||||
'class/c-first-order-augride-4
|
||||
'(contract (class/c (augride [m (-> any/c number? number?)]))
|
||||
(class object% (super-new) (define/public (m x) (add1 x)))
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(test/spec-passed
|
||||
'class/c-first-order-augride-5
|
||||
'(contract (class/c (augride [m (-> any/c number? number?)]))
|
||||
(let ([c% (class object% (super-new) (define/pubment (m x) (inner x m x)))])
|
||||
(class c% (super-new) (define/augride (m x) (add1 x))))
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(test/pos-blame
|
||||
'class/c-first-order-augride-5
|
||||
'(contract (class/c (augride [m (-> any/c number? number?)]))
|
||||
(let ([c% (class object% (super-new) (define/public (m x) (add1 x)))])
|
||||
(class c% (super-new) (define/override (m x) (add1 (super m x)))))
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(test/spec-passed
|
||||
'class/c-first-order-augride-6
|
||||
'(contract (class/c (augride [m (-> any/c number? number?)]))
|
||||
(let* ([c% (class object% (super-new) (define/public (m x) (add1 x)))]
|
||||
[d% (class c% (super-new) (define/overment (m x) (+ (super m x) (inner x m x))))])
|
||||
(class d% (super-new) (define/augride (m x) x)))
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(test/pos-blame
|
||||
'class/c-first-order-augride-7
|
||||
'(contract (class/c (augride m))
|
||||
object%
|
||||
'pos
|
||||
'neg))
|
||||
|
||||
(test/spec-passed
|
||||
'class/c-first-order-augride-8
|
||||
'(let ([c% (contract (class/c (augride m))
|
||||
(class (class object% (super-new) (define/pubment (m) 3))
|
||||
(super-new) (define/augride (m) 4))
|
||||
'pos
|
||||
'neg)])
|
||||
(class c% (super-new) (inherit m))))
|
||||
|
||||
(test/pos-blame
|
||||
'class/c-first-order-augride-9
|
||||
'(let ([c% (contract (class/c (augride [m (-> any/c number? number?)]))
|
||||
(class (class object% (super-new) (define/pubment (m) 3))
|
||||
(super-new) (define/augride (m) 4))
|
||||
'pos
|
||||
'neg)])
|
||||
(class c% (super-new) (inherit m))))
|
||||
|
||||
(test/pos-blame
|
||||
'class/c-first-order-inherit-1
|
||||
'(let* ([c% (contract (class/c (inherit [m (-> any/c number? number?)]))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user