diff --git a/pkgs/racket-test/tests/racket/contract/stronger.rkt b/pkgs/racket-test/tests/racket/contract/stronger.rkt index dc30bfc608..53069f2bbb 100644 --- a/pkgs/racket-test/tests/racket/contract/stronger.rkt +++ b/pkgs/racket-test/tests/racket/contract/stronger.rkt @@ -444,6 +444,9 @@ (ctest #f contract-stronger? (implementation?/c one-interface<%>) (implementation?/c another-interface<%>)) + + (ctest #t contract-stronger? (evt/c integer?) (evt/c integer?)) + (ctest #f contract-stronger? (evt/c integer?) (evt/c boolean?)) ;; chances are, this predicate will accept "x", but ;; we don't want to consider it stronger, since it diff --git a/racket/collects/racket/contract/private/arrow-val-first.rkt b/racket/collects/racket/contract/private/arrow-val-first.rkt index eeb1adffc5..32497e22c2 100644 --- a/racket/collects/racket/contract/private/arrow-val-first.rkt +++ b/racket/collects/racket/contract/private/arrow-val-first.rkt @@ -1208,18 +1208,18 @@ (= (length (base->-doms that)) (length (base->-doms this))) (= (base->-min-arity this) (base->-min-arity that)) - (andmap contract-stronger? (base->-doms that) (base->-doms this)) + (andmap contract-struct-stronger? (base->-doms that) (base->-doms this)) (= (length (base->-kwd-infos this)) (length (base->-kwd-infos that))) (for/and ([this-kwd-info (base->-kwd-infos this)] [that-kwd-info (base->-kwd-infos that)]) (and (equal? (kwd-info-kwd this-kwd-info) (kwd-info-kwd that-kwd-info)) - (contract-stronger? (kwd-info-ctc that-kwd-info) - (kwd-info-ctc this-kwd-info)))) + (contract-struct-stronger? (kwd-info-ctc that-kwd-info) + (kwd-info-ctc this-kwd-info)))) (if (base->-rngs this) (and (base->-rngs that) - (andmap contract-stronger? (base->-rngs this) (base->-rngs that))) + (andmap contract-struct-stronger? (base->-rngs this) (base->-rngs that))) (not (base->-rngs that))) (not (base->-pre? this)) (not (base->-pre? that)) diff --git a/racket/collects/racket/contract/private/arrow.rkt b/racket/collects/racket/contract/private/arrow.rkt index 72b596f12f..384784b4a1 100644 --- a/racket/collects/racket/contract/private/arrow.rkt +++ b/racket/collects/racket/contract/private/arrow.rkt @@ -662,16 +662,16 @@ (define (->-stronger? this that) (and (base->? that) (= (length (base->-doms/c that)) (length (base->-doms/c this))) - (andmap contract-stronger? (base->-doms/c that) (base->-doms/c this)) + (andmap contract-struct-stronger? (base->-doms/c that) (base->-doms/c this)) (equal? (base->-mandatory-kwds this) (base->-mandatory-kwds that)) - (andmap contract-stronger? (base->-mandatory-kwds/c that) (base->-mandatory-kwds/c this)) + (andmap contract-struct-stronger? (base->-mandatory-kwds/c that) (base->-mandatory-kwds/c this)) (equal? (base->-optional-kwds this) (base->-optional-kwds that)) - (andmap contract-stronger? (base->-optional-kwds/c that) (base->-optional-kwds/c this)) + (andmap contract-struct-stronger? (base->-optional-kwds/c that) (base->-optional-kwds/c this)) (= (length (base->-rngs/c that)) (length (base->-rngs/c this))) - (andmap contract-stronger? (base->-rngs/c this) (base->-rngs/c that)) + (andmap contract-struct-stronger? (base->-rngs/c this) (base->-rngs/c that)) ;; these procs might be based on state; only ;; allow stronger to be true when #:pre and diff --git a/racket/collects/racket/contract/private/box.rkt b/racket/collects/racket/contract/private/box.rkt index 0abccd0365..e88d576cd1 100644 --- a/racket/collects/racket/contract/private/box.rkt +++ b/racket/collects/racket/contract/private/box.rkt @@ -99,11 +99,11 @@ (cond [(and (equal? this-immutable #t) (equal? that-immutable #t)) - (contract-stronger? this-content-r that-content-r)] + (contract-struct-stronger? this-content-r that-content-r)] [(or (equal? that-immutable 'dont-care) (equal? this-immutable that-immutable)) - (and (contract-stronger? this-content-r that-content-r) - (contract-stronger? that-content-w this-content-w))] + (and (contract-struct-stronger? this-content-r that-content-r) + (contract-struct-stronger? that-content-w this-content-w))] [else #f])] [else #f])) diff --git a/racket/collects/racket/contract/private/case-arrow.rkt b/racket/collects/racket/contract/private/case-arrow.rkt index f51e1862ef..b644cf10a9 100644 --- a/racket/collects/racket/contract/private/case-arrow.rkt +++ b/racket/collects/racket/contract/private/case-arrow.rkt @@ -333,6 +333,6 @@ (= (length fst) (length ps)) (for/and ([c (in-list ps)] [fst-c (in-list fst)]) - (and (contract-stronger? c fst-c) - (contract-stronger? fst-c c))))) + (and (contract-struct-stronger? c fst-c) + (contract-struct-stronger? fst-c c))))) fst)])) diff --git a/racket/collects/racket/contract/private/ds.rkt b/racket/collects/racket/contract/private/ds.rkt index 4341ec8bb6..8dc55bf60b 100644 --- a/racket/collects/racket/contract/private/ds.rkt +++ b/racket/collects/racket/contract/private/ds.rkt @@ -235,7 +235,7 @@ it around flattened out. [b-sel (contract-get b selector-indices)]) (if (contract-struct? a-sel) (if (contract-struct? b-sel) - (contract-stronger? a-sel b-sel) + (contract-struct-stronger? a-sel b-sel) #f) (if (contract-struct? b-sel) #f @@ -275,8 +275,8 @@ it around flattened out. (let ([old-contract/info (wrap-get val 1)]) (if (and (equal? (contract/info-blame new-contract/info) (contract/info-blame old-contract/info)) - (contract-stronger? (contract/info-contract old-contract/info) - (contract/info-contract new-contract/info))) + (contract-struct-stronger? (contract/info-contract old-contract/info) + (contract/info-contract new-contract/info))) #t (already-there? new-contract/info (wrap-get val 0) (- depth 1)))))] [else diff --git a/racket/collects/racket/contract/private/hash.rkt b/racket/collects/racket/contract/private/hash.rkt index deaeb3578d..712d735975 100644 --- a/racket/collects/racket/contract/private/hash.rkt +++ b/racket/collects/racket/contract/private/hash.rkt @@ -168,14 +168,14 @@ (cond [(and (equal? this-immutable #t) (equal? that-immutable #t)) - (and (contract-stronger? this-dom that-dom) - (contract-stronger? this-rng that-rng))] + (and (contract-struct-stronger? this-dom that-dom) + (contract-struct-stronger? this-rng that-rng))] [(or (equal? that-immutable 'dont-care) (equal? this-immutable that-immutable)) - (and (contract-stronger? this-dom that-dom) - (contract-stronger? that-dom this-dom) - (contract-stronger? this-rng that-rng) - (contract-stronger? that-rng this-rng))] + (and (contract-struct-stronger? this-dom that-dom) + (contract-struct-stronger? that-dom this-dom) + (contract-struct-stronger? this-rng that-rng) + (contract-struct-stronger? that-rng this-rng))] [else #f])] [else #f])) diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index 7a2dbe399e..ad5d3f2c6c 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -56,7 +56,9 @@ random-any/c rename-contract - if/c) + if/c + + pairwise-stronger-contracts?) (define-syntax (flat-murec-contract stx) (syntax-case stx () @@ -132,12 +134,8 @@ (define (and-stronger? this that) (and (base-and/c? that) - (let ([this-ctcs (base-and/c-ctcs this)] - [that-ctcs (base-and/c-ctcs that)]) - (and (= (length this-ctcs) (length that-ctcs)) - (andmap contract-stronger? - this-ctcs - that-ctcs))))) + (pairwise-stronger-contracts? (base-and/c-ctcs this) + (base-and/c-ctcs that)))) (define (and/c-generate? ctc) (cond @@ -206,21 +204,21 @@ (define (and/c-check-nonneg ctc pred) (define sub-contracts (base-and/c-ctcs ctc)) (cond - [(are-stronger-contracts? (list pred (not/c negative?)) - sub-contracts) + [(pairwise-stronger-contracts? (list pred (not/c negative?)) + sub-contracts) (define go (hash-ref predicate-generator-table pred)) (λ (fuel) (λ () (abs (go fuel))))] [else #f])) -(define (are-stronger-contracts? c1s c2s) +(define (pairwise-stronger-contracts? c1s c2s) (let loop ([c1s c1s] [c2s c2s]) (cond [(and (null? c1s) (null? c2s)) #t] [(and (pair? c1s) (pair? c2s)) - (and (contract-stronger? (car c1s) (car c2s)) + (and (contract-struct-stronger? (car c1s) (car c2s)) (loop (cdr c1s) (cdr c2s)))] [else #f]))) @@ -576,13 +574,13 @@ [(pe-listof-ctc? this) (pe-listof-ctc? that)] [(im-listof-ctc? this) (im-listof-ctc? that)] [else #t]) - (contract-stronger? this-elem that-elem))] + (contract-struct-stronger? this-elem that-elem))] [(the-cons/c? that) (define hd-ctc (the-cons/c-hd-ctc that)) (define tl-ctc (the-cons/c-tl-ctc that)) (and (ne-listof-ctc? this) - (contract-stronger? this-elem hd-ctc) - (contract-stronger? (ne->pe-ctc this) tl-ctc))] + (contract-struct-stronger? this-elem hd-ctc) + (contract-struct-stronger? (ne->pe-ctc this) tl-ctc))] [else #f])) (define (raise-listof-blame-error blame val empty-ok? neg-party) @@ -828,16 +826,16 @@ [(the-cons/c? that) (define that-hd (the-cons/c-hd-ctc that)) (define that-tl (the-cons/c-tl-ctc that)) - (and (contract-stronger? this-hd that-hd) - (contract-stronger? this-tl that-tl))] + (and (contract-struct-stronger? this-hd that-hd) + (contract-struct-stronger? this-tl that-tl))] [(ne-listof-ctc? that) (define elem-ctc (listof-ctc-elem-c that)) - (and (contract-stronger? this-hd elem-ctc) - (contract-stronger? this-tl (ne->pe-ctc that)))] + (and (contract-struct-stronger? this-hd elem-ctc) + (contract-struct-stronger? this-tl (ne->pe-ctc that)))] [(pe-listof-ctc? that) (define elem-ctc (listof-ctc-elem-c that)) - (and (contract-stronger? this-hd elem-ctc) - (contract-stronger? this-tl that))] + (and (contract-struct-stronger? this-hd elem-ctc) + (contract-struct-stronger? this-tl that))] [else #f])) @@ -1109,18 +1107,15 @@ (define (list/c-stronger this that) (cond [(generic-list/c? that) - (and (= (length (generic-list/c-args this)) - (length (generic-list/c-args that))) - (for/and ([this-s (in-list (generic-list/c-args this))] - [that-s (in-list (generic-list/c-args this))]) - (contract-stronger? this-s that-s)))] + (pairwise-stronger-contracts? (generic-list/c-args this) + (generic-list/c-args that))] [(listof-ctc? that) (define that-elem-ctc (listof-ctc-elem-c that)) (define this-elem-ctcs (generic-list/c-args this)) (and (or (pair? this-elem-ctcs) (pe-listof-ctc? that)) (for/and ([this-s (in-list this-elem-ctcs)]) - (contract-stronger? this-s that-elem-ctc)))] + (contract-struct-stronger? this-s that-elem-ctc)))] [else #f])) (struct generic-list/c (args)) @@ -1250,8 +1245,8 @@ #:name (λ (ctc) (build-compound-type-name 'syntax/c (syntax-ctc-ctc ctc))) #:stronger (λ (this that) (and (syntax-ctc? that) - (contract-stronger? (syntax-ctc-ctc this) - (syntax-ctc-ctc that)))) + (contract-struct-stronger? (syntax-ctc-ctc this) + (syntax-ctc-ctc that)))) #:first-order (λ (ctc) (define ? (flat-contract-predicate (syntax-ctc-ctc ctc))) (λ (v) @@ -1299,8 +1294,8 @@ (define (promise-ctc-stronger? this that) (and (promise-base-ctc? that) - (contract-stronger? (promise-base-ctc-ctc this) - (promise-base-ctc-ctc that)))) + (contract-struct-stronger? (promise-base-ctc-ctc this) + (promise-base-ctc-ctc that)))) (struct promise-base-ctc (ctc)) (struct chaperone-promise-ctc promise-base-ctc () @@ -1380,10 +1375,10 @@ #:stronger (λ (this that) (and (parameter/c? that) - (and (contract-stronger? (parameter/c-out this) - (parameter/c-out that)) - (contract-stronger? (parameter/c-in that) - (parameter/c-in this))))))) + (and (contract-struct-stronger? (parameter/c-out this) + (parameter/c-out that)) + (contract-struct-stronger? (parameter/c-in that) + (parameter/c-in this))))))) (define-struct procedure-arity-includes/c (n) #:property prop:custom-write custom-write-property-proc @@ -1558,10 +1553,10 @@ (define (prompt-tag/c-stronger? this that) (and (base-prompt-tag/c? that) - (andmap (λ (this that) (contract-stronger? this that)) + (andmap (λ (this that) (contract-struct-stronger? this that)) (base-prompt-tag/c-ctcs this) (base-prompt-tag/c-ctcs that)) - (andmap (λ (this that) (contract-stronger? this that)) + (andmap (λ (this that) (contract-struct-stronger? this that)) (base-prompt-tag/c-call/ccs this) (base-prompt-tag/c-call/ccs that)))) @@ -1626,7 +1621,7 @@ (define (continuation-mark-key/c-stronger? this that) (and (base-continuation-mark-key/c? that) - (contract-stronger? + (contract-struct-stronger? (base-continuation-mark-key/c-ctc this) (base-continuation-mark-key/c-ctc that)))) @@ -1707,9 +1702,7 @@ (define (evt/c-stronger? this that) (define this-ctcs (chaperone-evt/c-ctcs this)) (define that-ctcs (chaperone-evt/c-ctcs that)) - (and (= (length this-ctcs) (that-ctcs)) - (for/and ([this this-ctcs] [that that-ctcs]) - (contract-stronger? this that)))) + (pairwise-stronger-contracts? this-ctcs that-ctcs)) ;; ctcs - Listof (define-struct chaperone-evt/c (ctcs) @@ -1760,7 +1753,7 @@ (define (channel/c-stronger? this that) (and (base-channel/c? that) - (contract-stronger? + (contract-struct-stronger? (base-channel/c-ctc this) (base-channel/c-ctc that)))) @@ -1869,7 +1862,7 @@ (flat-named-contract name (flat-contract-predicate ctc)) (let* ([make-contract (if (chaperone-contract? ctc) make-chaperone-contract make-contract)]) (define (stronger? this other) - (contract-stronger? ctc other)) + (contract-struct-stronger? ctc other)) (make-contract #:name name #:late-neg-projection (get/build-late-neg-projection ctc) #:first-order (contract-first-order ctc) diff --git a/racket/collects/racket/contract/private/orc.rkt b/racket/collects/racket/contract/private/orc.rkt index dcb8bfc566..4077120e65 100644 --- a/racket/collects/racket/contract/private/orc.rkt +++ b/racket/collects/racket/contract/private/orc.rkt @@ -94,14 +94,10 @@ (define (single-or/c-stronger? this that) (or (and (single-or/c? that) - (contract-stronger? (single-or/c-ho-ctc this) - (single-or/c-ho-ctc that)) - (let ([this-ctcs (single-or/c-flat-ctcs this)] - [that-ctcs (single-or/c-flat-ctcs that)]) - (and (= (length this-ctcs) (length that-ctcs)) - (andmap contract-stronger? - this-ctcs - that-ctcs)))) + (contract-struct-stronger? (single-or/c-ho-ctc this) + (single-or/c-ho-ctc that)) + (pairwise-stronger-contracts? (single-or/c-flat-ctcs this) + (single-or/c-flat-ctcs that))) (generic-or/c-stronger? this that))) (define (generic-or/c-stronger? this that) @@ -111,7 +107,7 @@ that-sub-ctcs (for/and ([this-sub-ctc (in-list this-sub-ctcs)]) (for/or ([that-sub-ctc (in-list that-sub-ctcs)]) - (contract-stronger? this-sub-ctc that-sub-ctc))))) + (contract-struct-stronger? this-sub-ctc that-sub-ctc))))) (define (or/c-sub-contracts ctc) (cond @@ -304,14 +300,10 @@ (define (multi-or/c-stronger? this that) (or (and (multi-or/c? that) - (let ([this-ctcs (multi-or/c-ho-ctcs this)] - [that-ctcs (multi-or/c-ho-ctcs that)]) - (and (= (length this-ctcs) (length that-ctcs)) - (andmap contract-stronger? this-ctcs that-ctcs))) - (let ([this-ctcs (multi-or/c-flat-ctcs this)] - [that-ctcs (multi-or/c-flat-ctcs that)]) - (and (= (length this-ctcs) (length that-ctcs)) - (andmap contract-stronger? this-ctcs that-ctcs)))) + (pairwise-stronger-contracts? (multi-or/c-ho-ctcs this) + (multi-or/c-ho-ctcs that)) + (pairwise-stronger-contracts? (multi-or/c-flat-ctcs this) + (multi-or/c-flat-ctcs that))) (generic-or/c-stronger? this that))) (define (mult-or/c-list-contract? c) @@ -373,7 +365,7 @@ [(and (<= (length this-ctcs) (length that-ctcs)) (for/and ([this-ctc (in-list this-ctcs)] [that-ctc (in-list that-ctcs)]) - (contract-stronger? this-ctc that-ctc))) + (contract-struct-stronger? this-ctc that-ctc))) #t] [(and (andmap (λ (x) (or (eq-contract? x) (equal-contract? x))) this-ctcs) (andmap (λ (x) (or (eq-contract? x) (equal-contract? x))) that-ctcs)) @@ -522,7 +514,7 @@ [(equal? this that) #t] [(recur?) (parameterize ([recur? #f]) - (contract-stronger? (get-flat-rec-me this) that))] + (contract-struct-stronger? (get-flat-rec-me this) that))] [else #f]))) #:first-order (λ (ctc) diff --git a/racket/collects/racket/contract/private/parametric.rkt b/racket/collects/racket/contract/private/parametric.rkt index 34ac6bea4f..a0b072a104 100644 --- a/racket/collects/racket/contract/private/parametric.rkt +++ b/racket/collects/racket/contract/private/parametric.rkt @@ -49,8 +49,8 @@ (define instances (for/list ([var (in-list this-vars)]) (this-barrier/c #t var))) - (contract-stronger? (apply (polymorphic-contract-body this) instances) - (apply (polymorphic-contract-body that) instances))] + (contract-struct-stronger? (apply (polymorphic-contract-body this) instances) + (apply (polymorphic-contract-body that) instances))] [else #f])] [else #f])) #:late-neg-projection diff --git a/racket/collects/racket/contract/private/struct-dc.rkt b/racket/collects/racket/contract/private/struct-dc.rkt index 624ba27869..b422a1e69f 100644 --- a/racket/collects/racket/contract/private/struct-dc.rkt +++ b/racket/collects/racket/contract/private/struct-dc.rkt @@ -289,7 +289,7 @@ (λ (v neg-party) (cond [(and (struct/c-imp-prop-pred? v) - (contract-stronger? (struct/c-imp-prop-get v) ctc)) + (contract-struct-stronger? (struct/c-imp-prop-get v) ctc)) v] [else (unless (pred? v) @@ -653,8 +653,8 @@ (immutable? that-subcontract)) (and (lazy-immutable? this-subcontract) (lazy-immutable? that-subcontract))) - (contract-stronger? (indep-ctc this-subcontract) - (indep-ctc that-subcontract)))] + (contract-struct-stronger? (indep-ctc this-subcontract) + (indep-ctc that-subcontract)))] [(and (dep? this-subcontract) (dep? that-subcontract)) (and (or (dep-mutable? this-subcontract) diff --git a/racket/collects/racket/contract/private/vector.rkt b/racket/collects/racket/contract/private/vector.rkt index 648bc3c12e..9cc5eb8442 100644 --- a/racket/collects/racket/contract/private/vector.rkt +++ b/racket/collects/racket/contract/private/vector.rkt @@ -114,12 +114,12 @@ (cond [(and (equal? this-immutable #t) (equal? that-immutable #t)) - (contract-stronger? this-elem that-elem)] + (contract-struct-stronger? this-elem that-elem)] [else (and (or (equal? that-immutable 'dont-care) (equal? this-immutable that-immutable)) - (contract-stronger? this-elem that-elem) - (contract-stronger? that-elem this-elem))])] + (contract-struct-stronger? this-elem that-elem) + (contract-struct-stronger? that-elem this-elem))])] [else #f])) (define-struct (flat-vectorof base-vectorof) () @@ -325,14 +325,14 @@ (and (= (length this-elems) (length that-elems)) (for/and ([this-elem (in-list this-elems)] [that-elem (in-list that-elems)]) - (contract-stronger? this-elem that-elem)))] + (contract-struct-stronger? this-elem that-elem)))] [(or (equal? that-immutable 'dont-care) (equal? this-immutable that-immutable)) (and (= (length this-elems) (length that-elems)) (for/and ([this-elem (in-list this-elems)] [that-elem (in-list that-elems)]) - (and (contract-stronger? this-elem that-elem) - (contract-stronger? that-elem this-elem))))] + (and (contract-struct-stronger? this-elem that-elem) + (contract-struct-stronger? that-elem this-elem))))] [else #f])] [(base-vectorof? that) (define that-elem (base-vectorof-elem that)) @@ -341,12 +341,12 @@ [(and (equal? this-immutable #t) (equal? that-immutable #t)) (for/and ([this-elem (in-list this-elems)]) - (contract-stronger? this-elem that-elem))] + (contract-struct-stronger? this-elem that-elem))] [(or (equal? that-immutable 'dont-care) (equal? this-immutable that-immutable)) (for/and ([this-elem (in-list this-elems)]) - (and (contract-stronger? this-elem that-elem) - (contract-stronger? that-elem this-elem)))] + (and (contract-struct-stronger? this-elem that-elem) + (contract-struct-stronger? that-elem this-elem)))] [else #f])] [else #f]))