adjust implementation of recursive contract to cope with

the fact that blame object equality now works right and
adding context to a blame object doesn't produce an equal?
blame object

also it appears that blame-add-unknown-context is not actually
being called so lets just get rid of that functionality
(but preserve reasonable backwards compatibility in
case someone is actually calling that function or
supplying #f to blame-add-context)

And the interning of blame objects was not intended to be
in 0b3f4b627e, so get rid of it here

closes racket/typed-racket#722

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

@@ -2526,13 +2526,13 @@ The @racket[swap?] argument has the effect of calling @racket[blame-swap]
 while adding the layer of context, but without creating an extra
 @|blame-object|.
 
-The context information recorded in blame structs keeps track of
+
-combinators that do not add information, and add the string @racket["..."]
+Passing @racket[#f] as the context string argument is no longer relevant.
-for them, so programmers at least see that there was some context
+For backwards compatibility, @racket[blame-add-context] returns @racket[b]
-they are missing in the error messages. Accordingly, since there are
+when @racket[context] is @racket[#f].
-combinators that should not add any context (e.g., @racket[recursive-contract]),
+
-passing @racket[#f] as the context string argument avoids adding the
+@history[#:changed "6.90.0.29" @elem{The @racket[context] argument being
-@racket["..."] string.
+           @racket[#f] is no longer relevant.}]
 }
 
 @defproc[(blame-context [blame blame?]) (listof string?)]{

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

@@ -85,6 +85,15 @@
    '(letrec ([ctc (or/c number? (cons/c number? (recursive-contract ctc #:flat #:extra-delay)))])
       (contract ctc (cons 1 (cons 2 'not-a-number)) 'pos 'neg)))
 
+  (test/spec-passed/result
+   'recursive-contract14
+   '(let ()
+      (define c (recursive-contract (or/c integer? (cons/c c integer?))))
+      (void (contract (-> c any/c) void 'p 'n))
+      ((contract (-> c any/c) values 'p 'n) '(1 . 2)))
+   '(1 . 2))
+
+  
   (test/spec-passed/result
    'memoize-applied-blame
    '(let ()

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

@@ -170,6 +170,7 @@
     #`(#,maker '#,stx
                (λ () #,arg)
                '#,(syntax-local-infer-name stx)
+               'recursive-contract-val->lnp-not-yet-initialized
                #,(if list-contract? #'#t #'#f)
                #,@(if (equal? (syntax-e type) '#:flat)
                       (list (if extra-delay? #'#t #'#f))
@@ -207,6 +208,7 @@
        (unless (list-contract? forced-ctc)
          (raise-argument-error 'recursive-contract "list-contract?" forced-ctc)))
      (set-recursive-contract-ctc! ctc forced-ctc)
+     (set-recursive-contract-blame->val-np->val! ctc (make-blame->val-np->val ctc))
      (when (and (pair? old-name) (pair? (cdr old-name)))
        ;; this guard will be #f when we are forcing this contract
        ;; in a nested which (which can make the `cddr` below fail)
@@ -217,33 +219,48 @@
      forced-ctc]
     [else current]))
 
-(define (recursive-contract-late-neg-projection ctc)
+(define (make-blame->val-np->val ctc)
-  (cond
+  (define list-check? (recursive-contract-list-contract? ctc))
-    [(recursive-contract-list-contract? ctc)
+  (define blame-accepting-func-cell (make-thread-cell #f))
-     (λ (blame)
+  (define (do-list-check val neg-party blame-known)
-       (define r-ctc (force-recursive-contract ctc))
+    (when list-check?
-       (define f (get/build-late-neg-projection r-ctc))
-       (define blame-known (blame-add-context blame #f))
-       (define f-blame-known (make-thread-cell #f))
-       (λ (val neg-party)
       (unless (list? val)
         (raise-blame-error blame-known #:missing-party neg-party
                            val
                            '(expected: "list?" given: "~e")
-                              val))
+                           val))))
-         (unless (thread-cell-ref f-blame-known)
-           (thread-cell-set! f-blame-known (f blame-known)))
-         ((thread-cell-ref f-blame-known) val neg-party)))]
-    [else
   (λ (blame)
+    (cond
+      [(thread-cell-ref blame-accepting-func-cell)
+       =>
+       (λ (blame-accepting-func) (blame-accepting-func blame))]
+      [else
        (define r-ctc (force-recursive-contract ctc))
        (define f (get/build-late-neg-projection r-ctc))
-       (define blame-known (blame-add-context blame #f))
+       (define val-neg-party-acceptor (make-thread-cell #f))
-       (define f-blame-known (make-thread-cell #f))
        (λ (val neg-party)
-         (unless (thread-cell-ref f-blame-known)
+         (cond
-           (thread-cell-set! f-blame-known (f blame-known)))
+           [(thread-cell-ref val-neg-party-acceptor)
-         ((thread-cell-ref f-blame-known) val neg-party)))]))
+            =>
+            (λ (f) (f val neg-party))]
+           [else
+            (thread-cell-set! blame-accepting-func-cell
+                              (λ (blame)
+                                (λ (val neg-party)
+                                  ((thread-cell-ref val-neg-party-acceptor) val neg-party))))
+            (do-list-check val neg-party blame)
+            (define f-of-blame 'f-of-blame-not-yet-set)
+            (thread-cell-set! val-neg-party-acceptor
+                              (λ (val neg-party)
+                                (do-list-check val neg-party blame)
+                                (f-of-blame val neg-party)))
+            (set! f-of-blame (f blame))
+            (f-of-blame val neg-party)]))])))
+
+(define (recursive-contract-late-neg-projection ctc)
+  (λ (blame)
+    (force-recursive-contract ctc)
+    ((recursive-contract-blame->val-np->val ctc) blame)))
 
 (define (flat-recursive-contract-late-neg-projection ctc)
   (cond
@@ -287,7 +304,11 @@
        (force-recursive-contract ctc)
        (contract-random-generate/choose (recursive-contract-ctc ctc) (- fuel 1))])))
 
-(struct recursive-contract ([name #:mutable] [thunk #:mutable] [ctc #:mutable] list-contract?)
+(struct recursive-contract ([name #:mutable]
+                            thunk
+                            [ctc #:mutable]
+                            [blame->val-np->val #:mutable]
+                            list-contract?)
   #:property prop:recursive-contract (λ (this)
                                        (force-recursive-contract this)
                                        (recursive-contract-ctc this)))

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

@@ -39,32 +39,37 @@
 (define (combine-them x y)
   (bitwise-xor x (* 3 y)))
 
-(define (blame-hash b hash/recur)
+(define (blame-hash/combine b hash/recur combine-them)
   (combine-them (hash/recur (blame-no-swap? b))
                 (combine-them (hash/recur (blame-context-frame b))
                               (hash/recur (blame-and-more b)))))
 
+(define (blame-hash b hash/recur)
+  (blame-hash/combine b hash/recur (λ (x y) (bitwise-xor x (* 3 y)))))
+(define (blame-secondary-hash b hash/recur)
+  (blame-hash/combine b hash/recur (λ (x y) (bitwise-xor (* 5 x) y))))
+
 ;; missing-party? field is #t when the missing party
 ;; is still missing and it is #f when the missing party
 ;; has been filled in (or if it was filled in from the start)
 (define-struct all-the-info
   [positive
    negative
-   source value build-name top-known? important missing-party? context-limit extra-fields]
+   source value build-name important missing-party? context-limit extra-fields]
   #:transparent)
 
 ;; and-more : (or/c blame-no-swap? blame-swap? all-the-info?)
 ;; context : string?
 (define-struct blame (context-frame and-more)
   #:property prop:equal+hash
-  (list blame=? blame-hash blame-hash))
+  (list blame=? blame-hash blame-secondary-hash))
 
 (define-struct (blame-no-swap blame) ()
   #:property prop:equal+hash
-  (list blame=? blame-hash blame-hash))
+  (list blame=? blame-hash blame-secondary-hash))
 (define-struct (blame-yes-swap blame) ()
   #:property prop:equal+hash
-  (list blame=? blame-hash blame-hash))
+  (list blame=? blame-hash blame-secondary-hash))
 
 (define (blame->all-the-info b)
   (let loop ([b b])
@@ -73,7 +78,6 @@
       [else b])))
 (define (blame-source b) (all-the-info-source (blame->all-the-info b)))
 (define (blame-value b) (all-the-info-value (blame->all-the-info b)))
-(define (blame-top-known? b) (all-the-info-top-known? (blame->all-the-info b)))
 (define (blame-important b) (all-the-info-important (blame->all-the-info b)))
 (define (blame-missing-party? b) (all-the-info-missing-party? (blame->all-the-info b)))
 (define (blame-contract b) ((all-the-info-build-name (blame->all-the-info b))))
@@ -146,7 +150,6 @@
               source
               value
               build/memo-name
-              #t
               #f
               (not negative)
               context-limit
@@ -155,11 +158,10 @@
            ;; so be careful in other parts of the code to ignore
            ;; it, as appropriate.
            (if original?
-               (blame-no-swap/intern #f all-the-info)
+               (blame-no-swap #f all-the-info)
-               (blame-yes-swap/intern #f all-the-info)))])
+               (blame-yes-swap #f all-the-info)))])
     make-blame))
 
-(define seen '())
 (define (blame-add-context b s #:important [name #f] #:swap? [swap? #f])
   (unless (blame? b)
     (raise-argument-error 'blame-add-context
@@ -172,20 +174,15 @@
                           (format "~s" '(or/c string? #f))
                           1
                           b s))
-  (do-blame-add-context b s name swap?))
+  (cond
+    [(string? s)
+     (do-blame-add-context b s name swap?)]
+    [else b]))
 
-(define (blame-add-unknown-context b)
+;; this has become a no op. it seems to never have been
-  (do-blame-add-context b #f #f #f))
+;; documented. probably exported because of the Great
-
+;; Extra Export ScrewUp that happened years back
-(define (make-blame-yes/no-swap/intern blame-yes/no-swap)
+(define (blame-add-unknown-context b) b)
-  (define ht (make-hash))
-  (define (blame-yes/no-swap/intern s b)
-    (define b-table (hash-ref! ht s make-hash))
-    (hash-ref! b-table b (λ () (blame-yes/no-swap s b))))
-  blame-yes/no-swap/intern)
-
-(define blame-no-swap/intern (make-blame-yes/no-swap/intern blame-no-swap))
-(define blame-yes-swap/intern (make-blame-yes/no-swap/intern blame-yes-swap))
 
 (define (do-blame-add-context b s name swap?)
   (define context-limit (blame-context-limit b))
@@ -195,51 +192,44 @@
           ;; we are not updating the name
           ;; at the top of the messages either
           ;(not name)
-          (blame-top-known? b))
+          )
      (cond
-       [(and s (not (zero? context-limit)))
+       [(not (zero? context-limit))
         ;; if the limit is zero, we skip this case,
         ;; which has the effect of always keeping only
         ;; the dummy context frame
         (define-values (limited-b dropped-swap?) (drop-to-limit b context-limit))
         (if (equal? dropped-swap? swap?)
-            (blame-no-swap/intern s limited-b)
+            (blame-no-swap s limited-b)
-            (blame-yes-swap/intern s limited-b))]
+            (blame-yes-swap s limited-b))]
        [swap?
         (if (blame-yes-swap? b)
-            (blame-no-swap/intern (blame-context-frame b) (blame-and-more b))
+            (blame-no-swap (blame-context-frame b) (blame-and-more b))
-            (blame-yes-swap/intern (blame-context-frame b) (blame-and-more b)))]
+            (blame-yes-swap (blame-context-frame b) (blame-and-more b)))]
        [else b])]
     [else
-     (define blame-yes/no-swap (if swap? blame-yes-swap/intern blame-no-swap/intern))
+     (define blame-yes/no-swap (if swap? blame-yes-swap blame-no-swap))
      (define inside-part
-       (let/ec k
+       (cond
+         [name
           (let loop ([inner-b b])
             (cond
               [(blame-yes-swap? inner-b)
-              (blame-yes-swap/intern (blame-context-frame inner-b) (loop (blame-and-more inner-b)))]
+               (blame-yes-swap (blame-context-frame inner-b) (loop (blame-and-more inner-b)))]
               [(blame-no-swap? inner-b)
-              (blame-no-swap/intern (blame-context-frame inner-b) (loop (blame-and-more inner-b)))]
+               (blame-no-swap (blame-context-frame inner-b) (loop (blame-and-more inner-b)))]
               [else
-              (define top-known? (all-the-info-top-known? inner-b))
-              (cond
-                [(or (equal? top-known? (string? s))
-                     name)
                (define new-original? (if swap? (not (blame-original? b)) (blame-original? b)))
                ;; in this case, we need to make a new blame record
                (struct-copy
                 all-the-info inner-b
                 [important (if name
                                (important name new-original?)
-                                 (all-the-info-important inner-b))]
+                               (all-the-info-important inner-b))])]))]
-                  [top-known? (string? s)])]
+         [else b]))
-                [else
-                 ;; we can skip all that pending work
-                 ;; of making a copy in this case
-                 (k b)])]))))
      (if swap?
-         (blame-yes-swap/intern s inside-part)
+         (blame-yes-swap s inside-part)
-         (blame-no-swap/intern s inside-part))]))
+         (blame-no-swap s inside-part))]))
 
 (define (drop-to-limit b context-limit)
   (define short-enough?
@@ -269,10 +259,10 @@
                  (set! swapped? swap?)
                  b]))]
            [(blame-no-swap? b)
-            (blame-no-swap/intern (blame-context-frame b)
+            (blame-no-swap (blame-context-frame b)
                                   (loop (blame-and-more b) (- n 1)))]
            [(blame-yes-swap? b)
-            (blame-yes-swap/intern (blame-context-frame b)
+            (blame-yes-swap (blame-context-frame b)
                                    (loop (blame-and-more b) (- n 1)))])))
      (values limited-b swapped?)]))
   
@@ -281,9 +271,9 @@
 (define (blame-swap b)
   (cond
     [(blame-yes-swap? b)
-     (blame-no-swap/intern (blame-context-frame b) (blame-and-more b))]
+     (blame-no-swap (blame-context-frame b) (blame-and-more b))]
     [(blame-no-swap? b)
-     (blame-yes-swap/intern (blame-context-frame b) (blame-and-more b))]))
+     (blame-yes-swap (blame-context-frame b) (blame-and-more b))]))
 
 (define (blame-replace-negative b new-neg)
   (update-the-info
@@ -331,9 +321,9 @@
              [swap? #f])
     (cond
       [(blame-yes-swap? b)
-       (blame-yes-swap/intern (blame-context-frame b) (loop (blame-and-more b) (not swap?)))]
+       (blame-yes-swap (blame-context-frame b) (loop (blame-and-more b) (not swap?)))]
       [(blame-no-swap? b)
-       (blame-no-swap/intern (blame-context-frame b) (loop (blame-and-more b) swap?))]
+       (blame-no-swap (blame-context-frame b) (loop (blame-and-more b) swap?))]
       [else (f b swap?)])))
 
 (define (ensure-blame-known who blame)

racket/collects/racket/contract/private/prop.rkt

@@ -364,12 +364,6 @@
                    'anonymous-flat-contract 'build-flat-contract-property #t #t)
    'build-flat-contract-property))
 
-(define (blame-context-projection-wrapper proj)
-  (λ (ctc)
-    (define c-proj (proj ctc))
-    (λ (blame)
-      (c-proj (blame-add-unknown-context blame)))))
-
 (define build-chaperone-contract-property
   (procedure-rename
    (build-property (compose make-chaperone-contract-property make-contract-property)