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 eafed86219..b0494e3a60 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/stronger.rkt @@ -14,10 +14,22 @@ (ctest #f contract-stronger? (>=/c 2) (>=/c 3)) (ctest #f contract-stronger? (<=/c 3) (<=/c 2)) (ctest #t contract-stronger? (<=/c 2) (<=/c 3)) - (ctest #f contract-stronger? (recursive-contract (<=/c 2)) (recursive-contract (<=/c 3))) + (ctest #t contract-stronger? (recursive-contract (<=/c 2)) (recursive-contract (<=/c 3))) (ctest #f contract-stronger? (recursive-contract (<=/c 3)) (recursive-contract (<=/c 2))) (let ([f (contract-eval '(λ (x) (recursive-contract (<=/c x))))]) (test #t (contract-eval 'contract-stronger?) (contract-eval `(,f 1)) (contract-eval `(,f 1)))) + (ctest #t contract-stronger? + (letrec ([c (recursive-contract (-> (<=/c 5) c))]) c) + (letrec ([c (recursive-contract (-> (<=/c 3) c))]) c)) + (ctest #t contract-stronger? + (letrec ([c (recursive-contract (-> (<=/c 3) c))]) c) + (letrec ([c (recursive-contract (-> (<=/c 1) c))]) c)) + (ctest #t contract-stronger? + (letrec ([c (recursive-contract (-> (<=/c 3) c))]) c) + (letrec ([c (recursive-contract (-> (<=/c 1) (-> (<=/c 1) c)))]) c)) + (ctest #t contract-stronger? + (letrec ([c (recursive-contract (-> (<=/c 1) (-> (<=/c 1) c)))]) c) + (letrec ([c (recursive-contract (-> (<=/c 1) (-> (<=/c 1) (-> (<=/c 1) c))))]) c)) (ctest #t contract-stronger? (-> integer? integer?) (-> integer? integer?)) (ctest #f contract-stronger? (-> boolean? boolean?) (-> integer? integer?)) (ctest #t contract-stronger? (-> (>=/c 3) (>=/c 3)) (-> (>=/c 4) (>=/c 3))) diff --git a/racket/collects/racket/contract/private/base.rkt b/racket/collects/racket/contract/private/base.rkt index 6c7f0c1c6f..5a36858ffd 100644 --- a/racket/collects/racket/contract/private/base.rkt +++ b/racket/collects/racket/contract/private/base.rkt @@ -174,16 +174,18 @@ (λ (val) ((f blame-known) val)))])) -(define (recursive-contract-stronger this that) - (and (recursive-contract? that) - (procedure-closure-contents-eq? (recursive-contract-thunk this) - (recursive-contract-thunk that)))) +(define (recursive-contract-stronger this that) (equal? this that)) + +(define trail (make-parameter #f)) (define ((recursive-contract-first-order ctc) val) (contract-first-order-passes? (force-recursive-contract ctc) val)) -(struct recursive-contract ([name #:mutable] thunk [ctc #:mutable] list-contract?)) +(struct recursive-contract ([name #:mutable] thunk [ctc #:mutable] list-contract?) + #:property prop:recursive-contract (λ (this) + (force-recursive-contract this) + (recursive-contract-ctc this))) (struct flat-recursive-contract recursive-contract () #:property prop:custom-write custom-write-property-proc diff --git a/racket/collects/racket/contract/private/prop.rkt b/racket/collects/racket/contract/private/prop.rkt index fb9beabc00..28634db296 100644 --- a/racket/collects/racket/contract/private/prop.rkt +++ b/racket/collects/racket/contract/private/prop.rkt @@ -42,7 +42,16 @@ prop:orc-contract prop:orc-contract? - prop:orc-contract-get-subcontracts) + prop:orc-contract-get-subcontracts + + prop:recursive-contract + prop:recursive-contract? + prop:recursive-contract-unroll + + prop:arrow-contract + prop:arrow-contract? + prop:arrow-contract-get-info + (struct-out arrow-contract-info)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -97,17 +106,36 @@ (and get-projection (get-projection c))) +(define trail (make-parameter #f)) (define (contract-struct-stronger? a b) (define prop (contract-struct-property a)) (define stronger? (contract-property-stronger prop)) - (let loop ([b b]) - (cond - [(stronger? a b) #t] - [(prop:orc-contract? b) - (define sub-contracts ((prop:orc-contract-get-subcontracts b) b)) - (for/or ([sub-contract (in-list sub-contracts)]) - (loop sub-contract))] - [else #f]))) + (cond + [(let ([tc (trail)]) + (and tc + (ormap (λ (pr) (and (equal? (car pr) a) (equal? (cdr pr) b))) + (unbox tc)))) + #t] + [(or (prop:recursive-contract? a) (prop:recursive-contract? b)) + (parameterize ([trail (or (trail) (box '()))]) + (define trail-b (trail)) + (define trail-c (unbox trail-b)) + (set-box! trail-b (cons (cons a b) trail-c)) + (contract-struct-stronger? (if (prop:recursive-contract? a) + ((prop:recursive-contract-unroll a) a) + a) + (if (prop:recursive-contract? b) + ((prop:recursive-contract-unroll b) b) + b)))] + [else + (let loop ([b b]) + (cond + [(stronger? a b) #t] + [(prop:orc-contract? b) + (define sub-contracts ((prop:orc-contract-get-subcontracts b) b)) + (for/or ([sub-contract (in-list sub-contracts)]) + (loop sub-contract))] + [else #f]))])) (define (contract-struct-generate c) (define prop (contract-struct-property c)) @@ -446,3 +474,22 @@ ;; returns a list of contracts that were the original arguments to the or/c (define-values (prop:orc-contract prop:orc-contract? prop:orc-contract-get-subcontracts) (make-struct-type-property 'prop:orc-contract)) + +;; property should be bound to a function that accepts the contract +;; and returns a new contract, after unrolling one time +(define-values (prop:recursive-contract + prop:recursive-contract? + prop:recursive-contract-unroll) + (make-struct-type-property 'prop:recursive-contract)) + +;; get-info : (-> ctc arrow-contract-info?) +(define-values (prop:arrow-contract prop:arrow-contract? prop:arrow-contract-get-info) + (make-struct-type-property 'prop:arrow-contract)) + +;; chaperone-procedure : +;; (-> any/c[val] blame? procedure[suitable for second argument to chaperone-procedure]) +;; check-first-order : any/c[val] blame? -> void? +;; raises a blame error if val doesn't satisfy the first-order checks for the function +;; accepts-arglist : (-> (listof keyword?)[sorted by keyword