Ported opt-guts.ss and opt.ss to use new properties.

svn: r17687

collects/scheme/contract/private/opt-guts.ss

@@ -10,11 +10,7 @@
          make-opt/info
          opt/info-contract
          opt/info-val
-         opt/info-pos
+         opt/info-blame
-         opt/info-neg
-         opt/info-src-info
-         opt/info-orig-str
-         opt/info-positive-position?
          opt/info-free-vars
          opt/info-recf
          opt/info-base-pred
@@ -57,52 +53,22 @@
 
 ;; struct for color-keeping across opters
 (define-struct opt/info
-  (contract val pos neg src-info orig-str position-var position-swap?
+  (contract val blame-id swap-blame? free-vars recf base-pred this that))
-            free-vars recf base-pred this that))
 
-(define (opt/info-positive-position? oi)
+(define (opt/info-blame oi)
-  (if (opt/info-position-swap? oi)
+  (if (opt/info-swap-blame? oi)
-    #`(not #,(opt/info-position-var oi))
+    #`(blame-swap #,(opt/info-blame-id oi))
-    (opt/info-position-var oi)))
+    (opt/info-blame-id oi)))
 
 ;; opt/info-swap-blame : opt/info -> opt/info
 ;; swaps pos and neg
 (define (opt/info-swap-blame info)
-  (let ((ctc (opt/info-contract info))
+  (struct-copy opt/info info [swap-blame? (not (opt/info-swap-blame? info))]))
-        (val (opt/info-val info))
-        (pos (opt/info-pos info))
-        (neg (opt/info-neg info))
-        (position-var (opt/info-position-var info))
-        (position-swap? (opt/info-position-swap? info))
-        (src-info (opt/info-src-info info))
-        (orig-str (opt/info-orig-str info))
-        (free-vars (opt/info-free-vars info))
-        (recf (opt/info-recf info))
-        (base-pred (opt/info-base-pred info))
-        (this (opt/info-this info))
-        (that (opt/info-that info)))
-    (make-opt/info ctc val neg pos src-info orig-str
-                   position-var (not position-swap?)
-                   free-vars recf base-pred this that)))
 
 ;; opt/info-change-val : identifier opt/info -> opt/info
 ;; changes the name of the variable that the value-to-be-contracted is bound to
 (define (opt/info-change-val val info)
-  (let ((ctc (opt/info-contract info))
+  (struct-copy opt/info info [val val]))
-        (pos (opt/info-pos info))
-        (neg (opt/info-neg info))
-        (position-var (opt/info-position-var info))
-        (position-swap? (opt/info-position-swap? info))
-        (src-info (opt/info-src-info info))
-        (orig-str (opt/info-orig-str info))
-        (free-vars (opt/info-free-vars info))
-        (recf (opt/info-recf info))
-        (base-pred (opt/info-base-pred info))
-        (this (opt/info-this info))
-        (that (opt/info-that info)))
-    (make-opt/info ctc val pos neg src-info orig-str
-                   position-var position-swap?
-                   free-vars recf base-pred this that)))
 
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -199,17 +165,13 @@
      (list (cons
             partial-var
             (with-syntax ((lift-var lift-var)
-                          (pos (opt/info-pos opt/info))
+                          (blame (opt/info-blame opt/info)))
-                          (neg (opt/info-neg opt/info))
+              (syntax ((contract-projection lift-var) blame))))
-                          (src-info (opt/info-src-info opt/info))
-                          (orig-str (opt/info-orig-str opt/info))
-                          (positive-position? (opt/info-positive-position? opt/info)))
-              (syntax (((proj-get lift-var) lift-var) pos neg src-info orig-str positive-position?))))
            (cons
             partial-flat-var
             (with-syntax ((lift-var lift-var))
-              (syntax (if (flat-pred? lift-var)
+              (syntax (if (flat-contract? lift-var)
-                          ((flat-get lift-var) lift-var)
+                          (flat-contract-predicate lift-var)
                           (lambda (x) (error 'opt/unknown "flat called on an unknown that had no flat pred ~s ~s"
                                              lift-var
                                              x)))))))

collects/scheme/contract/private/opt.ss

@@ -62,13 +62,9 @@
   (values
    (with-syntax ((stx stx)
                  (val (opt/info-val opt/info))
-                 (pos (opt/info-pos opt/info))
+                 (blame (opt/info-blame opt/info)))
-                 (neg (opt/info-neg opt/info))
-                 (src-info (opt/info-src-info opt/info))
-                 (orig-str (opt/info-orig-str opt/info))
-                 (positive-position? (opt/info-positive-position? opt/info)))
      (syntax (let ((ctc stx))
-               ((((proj-get ctc) ctc) pos neg src-info orig-str positive-position?) val))))
+               (((contract-projection ctc) blame) val))))
    null
    null
    null
@@ -122,11 +118,7 @@
     [(_ e (opt-recursive-args ...))
      (let*-values ([(info) (make-opt/info #'ctc
                                           #'val
-                                          #'pos
+                                          #'blame
-                                          #'neg
-                                          #'src-info
-                                          #'orig-str
-                                          #'positive-position?
                                           #f
                                           (syntax->list #'(opt-recursive-args ...))
                                           #f
@@ -141,7 +133,7 @@
            lifts
            #`(make-opt-contract
               (λ (ctc)
-                (λ (pos neg src-info orig-str positive-position?)
+                (λ (blame)
                   #,(if (syntax-parameter-value #'define/opt-recursive-fn)
                         (with-syntax ([f (syntax-parameter-value #'define/opt-recursive-fn)])
                           (bind-superlifts
@@ -179,16 +171,18 @@
   (make-struct-type-property 'original-contract))
 
 (define-struct opt-contract (proj orig-ctc stronger stronger-vars stamp)
-  #:property proj-prop (λ (ctc) ((opt-contract-proj ctc) ctc))
-   ;; I think provide/contract and contract calls this, so we are in effect allocating
-   ;; the original once 
-  #:property name-prop (λ (ctc) (contract-name ((orig-ctc-get ctc) ctc)))
   #:property orig-ctc-prop (λ (ctc) ((opt-contract-orig-ctc ctc)))
-  #:property stronger-prop
+  #:property prop:contract
-  (λ (this that)
+  (build-contract-property
-    (and (opt-contract? that)
+   #:projection (λ (ctc) ((opt-contract-proj ctc) ctc))
-         (eq? (opt-contract-stamp this) (opt-contract-stamp that))
+   ;; I think provide/contract and contract calls this, so we are in effect allocating
-         ((opt-contract-stronger this) this that))))
+   ;; the original once
+   #:name (λ (ctc) (contract-name ((orig-ctc-get ctc) ctc)))
+   #:stronger
+   (λ (this that)
+      (and (opt-contract? that)
+           (eq? (opt-contract-stamp this) (opt-contract-stamp that))
+           ((opt-contract-stronger this) this that)))))
 
 ;; opt-stronger-vars-ref : int opt-contract -> any
 (define (opt-stronger-vars-ref i ctc)