diff --git a/pkgs/racket-test/tests/racket/contract/set.rkt b/pkgs/racket-test/tests/racket/contract/set.rkt index a5a0c150d0..1678137129 100644 --- a/pkgs/racket-test/tests/racket/contract/set.rkt +++ b/pkgs/racket-test/tests/racket/contract/set.rkt @@ -166,12 +166,20 @@ (binary-set 5) 'pos 'neg))) - (test/spec-passed + (test/spec-passed/result 'set/c21 '(let* ([c (set/c (-> integer? integer?))] [s (contract c (set (λ (x) x)) 'pos 'neg)]) (and (has-contract? s) - (equal? (value-contract s) c)))) + (equal? (value-contract s) c))) + #t) + + (test/spec-passed/result + 'set/c2b + '(let* ([c (set/c (-> integer? integer?))] + [s (contract c (set (λ (x) x)) 'pos 'neg)]) + (has-blame? s)) + #t) (test/spec-passed 'set/c22 @@ -207,14 +215,34 @@ (test/neg-blame 'set/c28 - '(let ([s (contract (set/c integer? #:lazy? #t) - (set #f) 'pos 'neg)]) + '(let ([s (contract (set/c integer? #:lazy? #t #:kind 'dont-care) + (mutable-set #f) 'pos 'neg)]) (set-add! s "x"))) (test/neg-blame 'set/c29 - '(let ([s (contract (set/c integer? #:lazy? #f) - (set 0) 'pos 'neg)]) + '(let ([s (contract (set/c integer? #:lazy? #f #:kind 'mutable) + (mutable-set 0) 'pos 'neg)]) (set-add! s "x"))) + + (test/spec-passed + 'set/c30 + '(let () + (define-custom-set-types set2 equal?) + (set-add + (contract (set/c (-> integer? integer?)) + (make-immutable-set2) + 'pos 'neg) + add1))) + + (test/spec-passed + 'set/c30 + '(let () + (define-custom-set-types set2 equal?) + (set-add + (contract (set/c (-> integer? integer?)) + (make-immutable-set2) + 'pos 'neg) + add1))) ) diff --git a/racket/collects/racket/set.rkt b/racket/collects/racket/set.rkt index 5ddafc515f..301cfe134c 100644 --- a/racket/collects/racket/set.rkt +++ b/racket/collects/racket/set.rkt @@ -184,50 +184,42 @@ (λ (blame) (define late-neg-pos-proj (late-neg-ele-proj (blame-add-element-context blame #f))) (define late-neg-neg-proj (late-neg-ele-proj (blame-add-element-context blame #t))) - (define set/c-lazy-late-neg-proj - (λ (val neg-party) + (cond + [lazy? + (λ (val neg-party) (set-contract-check cmp kind blame neg-party val) (define (pos-interpose val ele) (late-neg-pos-proj ele neg-party)) - (cond - [(set? val) - (chaperone-hash-set - val - pos-interpose - (λ (val ele) ele) - pos-interpose - impersonator-prop:contracted - ctc)] - [else - (chaperone-hash-set - val - pos-interpose - (λ (val ele) (late-neg-neg-proj ele neg-party)) - pos-interpose - impersonator-prop:contracted - ctc)]))) - (cond - [lazy? set/c-lazy-late-neg-proj] + (chaperone-hash-set + val + pos-interpose + (λ (val ele) (late-neg-neg-proj ele neg-party)) + pos-interpose + impersonator-prop:contracted ctc + impersonator-prop:blame (cons blame neg-party)))] [else (λ (val neg-party) (set-contract-check cmp kind blame neg-party val) - (define w/chaperone - (cond - [(set? val) val] - [else - (chaperone-hash-set - val - (λ (val ele) ele) - (λ (val ele) (late-neg-neg-proj ele neg-party)) - (λ (val ele) ele))])) - (chaperone-hash-set - (for/set ([ele (in-set w/chaperone)]) - (late-neg-pos-proj ele neg-party)) - (chaperone-hash-set - val - #f #f #f - impersonator-prop:contracted - ctc)))]))) - + (cond + [(set? val) + (chaperone-hash-set + (for/fold ([s (set-clear val)]) + ([e (in-set val)]) + (set-add s (late-neg-pos-proj e neg-party))) + #f #f #f + impersonator-prop:contracted ctc + impersonator-prop:blame (cons blame neg-party))] + [else + (define (pos-interpose val ele) (late-neg-pos-proj ele neg-party)) + (for ([ele (in-list (set->list val))]) + (set-remove! val ele) + (set-add! val (late-neg-pos-proj ele neg-party))) + (chaperone-hash-set + val + pos-interpose + (λ (val ele) (late-neg-neg-proj ele neg-party)) + pos-interpose + impersonator-prop:contracted ctc + impersonator-prop:blame (cons blame neg-party))]))]))) (define (generic-set-late-neg-projection ctc chaperone-ctc?) (define elem/c (set-contract-elem/c ctc))