diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt index 89aa48794a..0e1811657e 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt @@ -204,6 +204,27 @@ (struct/dc s [a number?] [b number?])) + + (,test #f + contract-stronger? + (struct/dc s + [a integer?] + [b integer?]) + (struct/dc s + [a integer?] + [b integer?] + #:inv (a b) #f)) + + (,test #t + contract-stronger? + (struct/dc s + [a integer?] + [b integer?] + #:inv (a b) #f) + (struct/dc s + [a integer?] + [b integer?])) + (define (mk c) (struct/dc s diff --git a/racket/collects/racket/contract/private/struct-dc.rkt b/racket/collects/racket/contract/private/struct-dc.rkt index 487e210a91..8885835f2a 100644 --- a/racket/collects/racket/contract/private/struct-dc.rkt +++ b/racket/collects/racket/contract/private/struct-dc.rkt @@ -594,6 +594,14 @@ (define (struct/dc-stronger? this that) (and (base-struct/dc? that) (eq? (base-struct/dc-pred this) (base-struct/dc-pred that)) + (let ([this-inv (get-invariant this)] + [that-inv (get-invariant that)]) + (cond + [(not that-inv) #t] + [(not this-inv) #f] + [else + (procedure-closure-contents-eq? (invariant-dep-proc this-inv) + (invariant-dep-proc that-inv))])) (for/and ([this-subcontract (in-list (base-struct/dc-subcontracts this))] [that-subcontract (in-list (base-struct/dc-subcontracts that))]) (cond @@ -618,6 +626,11 @@ (dep-dep-proc that-subcontract)))] [else #t])))) +(define (get-invariant sc) + (for/or ([sub (base-struct/dc-subcontracts sc)] + #:when (invariant? sub)) + sub)) + (define-struct base-struct/dc (subcontracts pred struct-name here name-info struct/c?)) (define-struct (struct/dc base-struct/dc) ()