Ported opt-guts.ss and opt.ss to use new properties.
svn: r17687
This commit is contained in:
parent
1d9b4a79b7
commit
d10eea83e7
|
@ -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)))))))
|
||||
|
|
|
@ -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)
|
||||
|
|
Loading…
Reference in New Issue
Block a user