From d10eea83e769b9067e08ca3e5b6cbea2a6b293f7 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Sun, 17 Jan 2010 03:54:22 +0000 Subject: [PATCH] Ported opt-guts.ss and opt.ss to use new properties. svn: r17687 --- collects/scheme/contract/private/opt-guts.ss | 62 ++++---------------- collects/scheme/contract/private/opt.ss | 36 +++++------- 2 files changed, 27 insertions(+), 71 deletions(-) diff --git a/collects/scheme/contract/private/opt-guts.ss b/collects/scheme/contract/private/opt-guts.ss index 1dedd43c54..9e19ee0bbc 100644 --- a/collects/scheme/contract/private/opt-guts.ss +++ b/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-neg - opt/info-src-info - opt/info-orig-str - opt/info-positive-position? + opt/info-blame 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? - free-vars recf base-pred this that)) + (contract val blame-id swap-blame? free-vars recf base-pred this that)) -(define (opt/info-positive-position? oi) - (if (opt/info-position-swap? oi) - #`(not #,(opt/info-position-var oi)) - (opt/info-position-var oi))) +(define (opt/info-blame oi) + (if (opt/info-swap-blame? oi) + #`(blame-swap #,(opt/info-blame-id 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)) - (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))) + (struct-copy opt/info info [swap-blame? (not (opt/info-swap-blame? info))])) ;; 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)) - (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))) + (struct-copy opt/info info [val val])) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -199,17 +165,13 @@ (list (cons partial-var (with-syntax ((lift-var lift-var) - (pos (opt/info-pos 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 (((proj-get lift-var) lift-var) pos neg src-info orig-str positive-position?)))) + (blame (opt/info-blame opt/info))) + (syntax ((contract-projection lift-var) blame)))) (cons partial-flat-var (with-syntax ((lift-var lift-var)) - (syntax (if (flat-pred? lift-var) - ((flat-get lift-var) lift-var) + (syntax (if (flat-contract? 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))))))) diff --git a/collects/scheme/contract/private/opt.ss b/collects/scheme/contract/private/opt.ss index 888b11c84c..8b69349574 100644 --- a/collects/scheme/contract/private/opt.ss +++ b/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)) - (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))) + (blame (opt/info-blame 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 - #'neg - #'src-info - #'orig-str - #'positive-position? + #'blame #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 - (λ (this that) - (and (opt-contract? that) - (eq? (opt-contract-stamp this) (opt-contract-stamp that)) - ((opt-contract-stronger this) this that)))) + #:property prop:contract + (build-contract-property + #:projection (λ (ctc) ((opt-contract-proj ctc) ctc)) + ;; I think provide/contract and contract calls this, so we are in effect allocating + ;; 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)