Those commits can change the blame assignment in

incorrect ways

This reverts commit 0aee13bf22.
This reverts commit a0880f7403.

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

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

racket/collects/racket/contract/base.rkt

@@ -64,7 +64,6 @@
  ;; from private/guts.rkt
  has-contract?
  value-contract
- value-contracts-and-blames
  has-blame?
  value-blame
  contract-continuation-mark-key

racket/collects/racket/contract/private/arr-i.rkt

@@ -845,22 +845,22 @@ evaluted left-to-right.)
      #`(λ #,wrapper-proc-arglist
          (λ (val)
            (chk val #,(and (syntax-parameter-value #'making-a-method) #t))
+           (let ([arg-checker
+                  (λ #,(args/vars->arglist an-istx wrapper-args this-param)
+                    #,wrapper-body)])
              (impersonate-procedure
               val
-              (let ([arg-checker
-                     (λ #,(args/vars->arglist an-istx wrapper-args this-param)
-                       #,wrapper-body)])
-                (make-keyword-procedure
-                 (λ (kwds kwd-args . args)
-                   (with-continuation-mark
-                       contract-continuation-mark-key blame
-                     (keyword-apply arg-checker kwds kwd-args args)))
-                 (λ args
-                   (with-continuation-mark
-                       contract-continuation-mark-key blame
-                     (apply arg-checker args)))))
+              (make-keyword-procedure
+               (λ (kwds kwd-args . args)
+                 (with-continuation-mark
+                     contract-continuation-mark-key blame
+                   (keyword-apply arg-checker kwds kwd-args args)))
+               (λ args
+                 (with-continuation-mark
+                     contract-continuation-mark-key blame
+                   (apply arg-checker args))))
               impersonator-prop:contracted ctc
-              impersonator-prop:blame blame))))))
+              impersonator-prop:blame blame)))))))
 
 (define-for-syntax (arg/res-to-indy-var indy-arg-vars ordered-args indy-res-vars ordered-ress var)
   (define (try vars ordered)

racket/collects/racket/contract/private/base.rkt

@@ -131,8 +131,7 @@
 (define (force-recursive-contract ctc)
   (define current (recursive-contract-ctc ctc))
   (cond
-    [(already-forced? ctc) current]
-    [else
+    [(or (symbol? current) (not current))
      (define thunk (recursive-contract-thunk ctc))
      (define old-name (recursive-contract-name ctc))
      (set-recursive-contract-name! ctc (or current '<recursive-contract>))
@@ -150,12 +149,9 @@
      (set-recursive-contract-ctc! ctc forced-ctc)
      (set-recursive-contract-name! ctc (append `(recursive-contract ,(contract-name forced-ctc))
                                                (cddr old-name)))
-     forced-ctc]))
+     forced-ctc]
+    [else current]))
 
-(define (already-forced? ctc)
-  (define current (recursive-contract-ctc ctc))
-  (and current (not (symbol? current))))
-  
 (define (recursive-contract-projection ctc)
   (cond
     [(recursive-contract-list-contract? ctc)
@@ -180,13 +176,8 @@
   
 (define (recursive-contract-stronger this that)
   (and (recursive-contract? that)
-       (or (procedure-closure-contents-eq? (recursive-contract-thunk this)
-                                           (recursive-contract-thunk that))
-           (if (and (already-forced? this)
-                    (already-forced? that))
-               (contract-stronger? (recursive-contract-ctc this)
-                                   (recursive-contract-ctc that))
-               #f))))
+       (procedure-closure-contents-eq? (recursive-contract-thunk this)
+                                       (recursive-contract-thunk that))))
 
 (define ((recursive-contract-first-order ctc) val)
   (contract-first-order-passes? (force-recursive-contract ctc)

racket/collects/racket/contract/private/blame.rkt

@@ -19,17 +19,11 @@
          
          blame-add-missing-party
          
-         blame-same-parties?
-         
          raise-blame-error
          current-blame-format
          (struct-out exn:fail:contract:blame)
          blame-fmt->-string)
 
-(define (blame-same-parties? a b)
-  (and (equal? (blame-positive a) (blame-positive b))
-       (equal? (blame-negative a) (blame-negative b))))
-
 (define (blame=? a b equal?/recur)
   (and (equal?/recur (blame-source a) (blame-source b))
        (equal?/recur (blame-value a) (blame-value b))

racket/collects/racket/contract/private/guts.rkt

@@ -27,14 +27,8 @@
          contract-first-order-passes?
          
          prop:contracted prop:blame
-         
-         impersonator-prop:contracts+blames
-         value-contracts-and-blames
-         
-         impersonator-prop:contracted
+         impersonator-prop:contracted impersonator-prop:blame
          has-contract? value-contract
-         
-         impersonator-prop:blame
          has-blame? value-blame
          
          ;; for opters
@@ -70,29 +64,12 @@
   (or (has-prop:contracted? v)
       (has-impersonator-prop:contracted? v)))
 
-(define (value-contracts-and-blames v)
-  (cond
-    [(and (has-prop:contracted? v)
-          (has-prop:blame? v))
-     (list (list (get-prop:contracted v)
-                 (get-prop:blame v)))]
-    [(and (has-impersonator-prop:contracted? v)
-          (has-impersonator-prop:blame? v))
-     (list (list (get-prop:contracted v)
-                 (get-prop:blame v)))]
-    [(has-impersonator-prop:contracts+blames? v)
-     (get-impersonator-prop:contracts+blames v)]
-    [else '()]))
-
 (define (value-contract v)
   (cond
     [(has-prop:contracted? v)
      (get-prop:contracted v)]
     [(has-impersonator-prop:contracted? v)
      (get-impersonator-prop:contracted v)]
-    [(has-impersonator-prop:contracts+blames? v)
-     (define l (get-impersonator-prop:contracts+blames v))
-     (list-ref (car l) 0)]
     [else #f]))
 
 (define (has-blame? v)
@@ -105,9 +82,6 @@
      (get-prop:blame v)]
     [(has-impersonator-prop:blame? v)
      (get-impersonator-prop:blame v)]
-    [(has-impersonator-prop:contracts+blames? v)
-     (define l (get-impersonator-prop:contracts+blames v))
-     (list-ref (car l) 1)]
     [else #f]))
 
 (define-values (prop:contracted has-prop:contracted? get-prop:contracted)
@@ -137,14 +111,8 @@
                 get-impersonator-prop:contracted)
   (make-impersonator-property 'impersonator-prop:contracted))
 
-;; bound to (non-empty-listof (list contract blame))
-(define-values (impersonator-prop:contracts+blames
-                has-impersonator-prop:contracts+blames?
-                get-impersonator-prop:contracts+blames)
-  (make-impersonator-property 'impersonator-prop:contracts+blames))
-
 (define-values (impersonator-prop:blame
-                has-impersonator-prop:blame?
+                has-impersonator-prop:blame? 
                 get-impersonator-prop:blame)
   (make-impersonator-property 'impersonator-prop:blame))
 

racket/collects/racket/private/class-c-old.rkt

@@ -825,7 +825,6 @@
    absents absent-fields 
    internal opaque? name)
   #:omit-define-syntaxes
-  #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property
    #:projection class/c-proj
@@ -1119,7 +1118,6 @@
                              (λ args (ret #f))))))
 
 (define-struct base-object/c (methods method-contracts fields field-contracts)
-  #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property 
    #:projection object/c-proj
@@ -1179,20 +1177,9 @@
           (wrapped-class-info-neg-field-projs the-info)
           neg-party)]
         [else
-         (define old-contracts-and-blames (value-contracts-and-blames val))
-         (cond
-           [(ormap (λ (pr)
-                     (define old-ctc (list-ref pr 0))
-                     (define old-blame (list-ref pr 1))
-                     (and (contract-stronger? old-ctc ctc)
-                          (blame-same-parties? old-blame blame)))
-                   old-contracts-and-blames)
-            val]
-           [else
-            (impersonate-struct val object-ref (λ (o c) new-cls)
-                                impersonator-prop:contracts+blames
-                                (cons (list ctc blame) old-contracts-and-blames)
-                                impersonator-prop:original-object original-obj)])]))))
+         (impersonate-struct val object-ref (λ (o c) new-cls)
+                             impersonator-prop:contracted ctc
+                             impersonator-prop:original-object original-obj)]))))
 
 (define (instanceof/c-first-order ctc)
   (let ([cls-ctc (base-instanceof/c-class-ctc ctc)])
@@ -1200,21 +1187,14 @@
       (and (object? val)
            (contract-first-order-passes? cls-ctc (object-ref val))))))
 
-(define (instanceof/c-stronger this that)
-  (and (base-instanceof/c? that)
-       (contract-stronger? (base-instanceof/c-class-ctc this)
-                           (base-instanceof/c-class-ctc that))))
-
 (define-struct base-instanceof/c (class-ctc)
-  #:property prop:custom-write custom-write-property-proc
   #:property prop:contract
   (build-contract-property 
    #:projection instanceof/c-proj
    #:name
    (λ (ctc)
      (build-compound-type-name 'instanceof/c (base-instanceof/c-class-ctc ctc)))
-   #:first-order instanceof/c-first-order
-   #:stronger instanceof/c-stronger))
+   #:first-order instanceof/c-first-order))
 
 (define (instanceof/c cctc)
   (let ([ctc (coerce-contract 'instanceof/c cctc)])