docs and tests related to a0880f740

pkgs/racket-pkgs/racket-doc/scribblings/reference/contracts.scrbl

@@ -2708,6 +2708,12 @@ Produces the name used to describe the contract in error messages.
   @history[#:added "6.0.1.12"]
 }
 
+@defproc[(value-contracts-and-blame [v any/c]) (listof (list/c blame? contract?))]{
+  Returns the contracts and associated blame that are attached to @racket[v].
+
+  @history[#:added "6.1.0.8"]
+}
+
 @defproc[(contract-projection [c contract?]) (-> blame? (-> any/c any/c))]{
   Produces the projection defining a contract's behavior on protected values.
 }

pkgs/racket-pkgs/racket-test/tests/racket/contract/class.rkt

@@ -2471,6 +2471,41 @@
       (chaperone-of? c+c% c%))
    #t)
   
+  (test/spec-passed/result
+   'lots-of-wrapping
+   '(let ()
+      (define state/c
+        (recursive-contract
+         (class/c
+          [m (-> any/c (instanceof/c state/c))]
+          [n (-> any/c (instanceof/c state/c))])))
+      
+      (define state% 
+        (class object%
+          (super-new)
+          (define/public (m) (send this n))
+          (define/public (n) (new state%))))
+      
+      (define tree-next
+        (contract 
+         (-> (instanceof/c state/c) (instanceof/c state/c))
+         (λ (o) (send o m))
+         'pos 'neg))
+      (define make-tree
+        (contract
+         (-> (instanceof/c state/c))
+         (λ () (new state%))
+         'pos
+         'neg))
+      
+      (define o1 (make-tree))
+      (define o2 (tree-next o1))
+      (define o3 (tree-next o2))
+      (= (length (value-contracts-and-blames o2))
+         (length (value-contracts-and-blames o3))))
+   #t)
+
+  
   (let ([expected-given?
          (λ (exn) (and (regexp-match? #rx"callback: contract violation" (exn-message exn))
                        (regexp-match? #rx"expected: boolean[?]" (exn-message exn))

pkgs/racket-pkgs/racket-test/tests/racket/contract/value-contract.rkt

@@ -10,40 +10,73 @@
   (ctest #f value-contract object%)
   
   (contract-eval
+   #:test-case-name 'value-contract1
    `(let ([ctc (-> number? number?)])
-      (,test ctc value-contract (contract ctc (λ (x) x) 'pos 'neg))))
+      (,test
+       #:test-case-name 'value-contract1
+       ctc value-contract (contract ctc (λ (x) x) 'pos 'neg))))
   (contract-eval
+   #:test-case-name 'value-contract2
    `(let ([ctc (->* (number?) (number?) number?)])
-      (,test ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg))))
+      (,test
+       #:test-case-name 'value-contract2
+       ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg))))
   (contract-eval
+   #:test-case-name 'value-contract3
    `(let ([ctc (->d ([x number?]) ([y number?]) [_ number?])])
-      (,test ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg))))
+      (,test
+       #:test-case-name 'value-contract3
+       ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg))))
   (contract-eval
+   #:test-case-name 'value-contract4
    `(let ([ctc (->i ([x number?]) ([y number?]) [_ number?])])
-      (,test ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg))))
+      (,test
+       #:test-case-name 'value-contract4
+       ctc value-contract (contract ctc (λ (x [y 3]) x) 'pos 'neg))))
   (contract-eval
+   #:test-case-name 'value-contract5
    `(let ([ctc (unconstrained-domain-> number?)])
-      (,test ctc value-contract (contract ctc (λ (x) 3) 'pos 'neg))))
+      (,test
+       #:test-case-name 'value-contract5
+       ctc value-contract (contract ctc (λ (x) 3) 'pos 'neg))))
   (contract-eval
+   #:test-case-name 'value-contract6
    `(let ([ctc (case-> (-> number? number? number?) (-> number? number?))])
-      (,test ctc value-contract (contract ctc (case-lambda [(x) 3] [(x y) (+ x y)]) 'pos 'neg))))
+      (,test
+       #:test-case-name 'value-contract6
+       ctc value-contract (contract ctc (case-lambda [(x) 3] [(x y) (+ x y)]) 'pos 'neg))))
   
   (contract-eval
+   #:test-case-name 'value-contract7
    `(let ([ctc (box/c number?)])
-      (,test ctc value-contract (contract ctc (box 3) 'pos 'neg))))
+      (,test
+       #:test-case-name 'value-contract7
+       ctc value-contract (contract ctc (box 3) 'pos 'neg))))
   (contract-eval
+   #:test-case-name 'value-contract8
    `(let ([ctc (hash/c number? number?)])
-      (,test ctc value-contract (contract ctc (make-hash) 'pos 'neg))))
+      (,test
+       #:test-case-name 'value-contract8
+       ctc value-contract (contract ctc (make-hash) 'pos 'neg))))
   (contract-eval
+   #:test-case-name 'value-contract9
    `(let ([ctc (vectorof number?)])
-      (,test ctc value-contract (contract ctc (vector 1 2 3) 'pos 'neg))))
+      (,test
+       #:test-case-name 'value-contract9
+       ctc value-contract (contract ctc (vector 1 2 3) 'pos 'neg))))
   (contract-eval
+   #:test-case-name 'value-contract10
    `(let ([ctc (vector/c number? number?)])
-      (,test ctc value-contract (contract ctc (vector 4 5) 'pos 'neg))))
+      (,test
+       #:test-case-name 'value-contract10
+       ctc value-contract (contract ctc (vector 4 5) 'pos 'neg))))
   
   (contract-eval
+   #:test-case-name 'value-contract11
    `(let ([ctc (object-contract)])
-      (,test ctc value-contract (contract ctc (new object%) 'pos 'neg))))
+      (,test
+       #:test-case-name 'value-contract11
+       ctc value-contract (contract ctc (new object%) 'pos 'neg))))
   
   (test/spec-passed/result
    'value-contract