improve contract-stronger and related things

Specifically, add a mechanism so that contract combinators
can accumulate contracts on a value (instead just storing
only one) and then use that in instanceof/c to avoid
putting contracts on values more often.

Also, fill in better contract-stronger implementations in
some of the combinators

racket/collects/racket/contract/base.rkt

@@ -64,6 +64,7 @@
  ;; 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
-              (make-keyword-procedure
+              (let ([arg-checker
-               (λ (kwds kwd-args . args)
+                     (λ #,(args/vars->arglist an-istx wrapper-args this-param)
-                 (with-continuation-mark
+                       #,wrapper-body)])
-                     contract-continuation-mark-key blame
+                (make-keyword-procedure
-                   (keyword-apply arg-checker kwds kwd-args args)))
+                 (λ (kwds kwd-args . args)
-               (λ args
+                   (with-continuation-mark
-                 (with-continuation-mark
+                       contract-continuation-mark-key blame
-                     contract-continuation-mark-key blame
+                     (keyword-apply arg-checker kwds kwd-args args)))
-                   (apply arg-checker 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,7 +131,8 @@
 (define (force-recursive-contract ctc)
   (define current (recursive-contract-ctc ctc))
   (cond
-    [(or (symbol? current) (not current))
+    [(already-forced? ctc) current]
+    [else
      (define thunk (recursive-contract-thunk ctc))
      (define old-name (recursive-contract-name ctc))
      (set-recursive-contract-name! ctc (or current '<recursive-contract>))
@@ -149,9 +150,12 @@
      (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)
@@ -176,8 +180,13 @@
   
 (define (recursive-contract-stronger this that)
   (and (recursive-contract? that)
-       (procedure-closure-contents-eq? (recursive-contract-thunk this)
+       (or (procedure-closure-contents-eq? (recursive-contract-thunk this)
-                                       (recursive-contract-thunk that))))
+                                           (recursive-contract-thunk that))
+           (if (and (already-forced? this)
+                    (already-forced? that))
+               (contract-stronger? (recursive-contract-ctc this)
+                                   (recursive-contract-ctc that))
+               #f))))
 
 (define ((recursive-contract-first-order ctc) val)
   (contract-first-order-passes? (force-recursive-contract ctc)

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

@@ -19,11 +19,17 @@
          
          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,8 +27,14 @@
          contract-first-order-passes?
          
          prop:contracted prop:blame
-         impersonator-prop:contracted impersonator-prop:blame
+         
+         impersonator-prop:contracts+blames
+         value-contracts-and-blames
+         
+         impersonator-prop:contracted
          has-contract? value-contract
+         
+         impersonator-prop:blame
          has-blame? value-blame
          
          ;; for opters
@@ -64,12 +70,29 @@
   (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)
@@ -82,6 +105,9 @@
      (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)
@@ -111,8 +137,14 @@
                 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,6 +825,7 @@
    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
@@ -1118,6 +1119,7 @@
                              (λ 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
@@ -1177,9 +1179,20 @@
           (wrapped-class-info-neg-field-projs the-info)
           neg-party)]
         [else
-         (impersonate-struct val object-ref (λ (o c) new-cls)
+         (define old-contracts-and-blames (value-contracts-and-blames val))
-                             impersonator-prop:contracted ctc
+         (cond
-                             impersonator-prop:original-object original-obj)]))))
+           [(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)])]))))
 
 (define (instanceof/c-first-order ctc)
   (let ([cls-ctc (base-instanceof/c-class-ctc ctc)])
@@ -1187,14 +1200,21 @@
       (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))
+   #:first-order instanceof/c-first-order
+   #:stronger instanceof/c-stronger))
 
 (define (instanceof/c cctc)
   (let ([ctc (coerce-contract 'instanceof/c cctc)])