suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

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

Browse Source 
svn: r17687
This commit is contained in:
Carl Eastlund 2010-01-17 03:54:22 +00:00
parent 1d9b4a79b7
commit d10eea83e7
2 changed files with 27 additions and 71 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

62
collects/scheme/contract/private/opt-guts.ss
View File

@ -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)))))))

36
collects/scheme/contract/private/opt.ss
View File

@ -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)