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

Ported ds.ss to new properties.

Browse Source 
svn: r17696
This commit is contained in:
Carl Eastlund 2010-01-17 06:10:29 +00:00
parent 41bd96f6aa
commit 336dd1b808
1 changed files with 26 additions and 44 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
collects/scheme/contract/private/ds.ss
View File

@ -219,11 +219,8 @@ it around flattened out.
ctc-field)] ctc-field)]
[ctc-field-val [ctc-field-val
((((proj-get ctc) ctc) (contract/info-pos contract/info) (((contract-predicate ctc)
(contract/info-neg contract/info) (contract/info-blame contract/info))
(contract/info-src-info contract/info)
(contract/info-orig-str contract/info)
(contract/info-positive-position? contract/info))
ctc-x)]) ctc-x)])
(update-parent-links parent ctc-field-val) (update-parent-links parent ctc-field-val)
ctc-field-val)] ...) ctc-field-val)] ...)
@ -231,22 +228,20 @@ it around flattened out.
(define (stronger-lazy-contract? a b) (define (stronger-lazy-contract? a b)
(and (contract-predicate b) (and (contract-predicate b)
(check-sub-contract? (contract-stronger?
(contract-get a selector-indicies) (contract-get a selector-indicies)
(contract-get b selector-indicies)) ...)) (contract-get b selector-indicies)) ...))
(define (lazy-contract-proj ctc) (define (lazy-contract-proj ctc)
(λ (pos-blame neg-blame src-info orig-str positive-position?) (λ (blame)
(let ([contract/info (make-contract/info ctc pos-blame neg-blame src-info orig-str positive-position?)]) (let ([contract/info (make-contract/info ctc blame)])
(λ (val) (λ (val)
(unless (or (wrap-predicate val) (unless (or (wrap-predicate val)
(opt-wrap-predicate val) (opt-wrap-predicate val)
(raw-predicate val)) (raw-predicate val))
(raise-contract-error (raise-blame-error
blame
val val
src-info
pos-blame
orig-str
"expected <~a>, got ~e" 'name val)) "expected <~a>, got ~e" 'name val))
(cond (cond
[(already-there? contract/info val lazy-depth-to-look) [(already-there? contract/info val lazy-depth-to-look)
@ -268,10 +263,8 @@ it around flattened out.
[(wrap-predicate val) [(wrap-predicate val)
(and (wrap-get val 0) (and (wrap-get val 0)
(let ([old-contract/info (wrap-get val 1)]) (let ([old-contract/info (wrap-get val 1)])
(if (and (eq? (contract/info-pos new-contract/info) (if (and (equal? (contract/info-blame new-contract/info)
(contract/info-pos old-contract/info)) (contract/info-blame old-contract/info))
(eq? (contract/info-neg new-contract/info)
(contract/info-neg old-contract/info))
(contract-stronger? (contract/info-contract old-contract/info) (contract-stronger? (contract/info-contract old-contract/info)
(contract/info-contract new-contract/info))) (contract/info-contract new-contract/info)))
#t #t
@ -311,6 +304,13 @@ it around flattened out.
'(fields ...) '(fields ...)
(contract-get ctc field-count))) (contract-get ctc field-count)))
(define lazy-contract-property
(build-contract-property
#:projection lazy-contract-proj
#:name lazy-contract-name
#:first-order (lambda (ctc) predicate)
#:stronger stronger-lazy-contract?))
(define-values (contract-type contract-maker contract-predicate contract-get contract-set) (define-values (contract-type contract-maker contract-predicate contract-get contract-set)
(make-struct-type 'contract-name (make-struct-type 'contract-name
#f #f
@ -322,10 +322,7 @@ it around flattened out.
;; this field is #f when there is no synthesized attrs ;; this field is #f when there is no synthesized attrs
0 ;; auto-field-k 0 ;; auto-field-k
'() ;; auto-field-v '() ;; auto-field-v
(list (cons proj-prop lazy-contract-proj) (list (cons prop:contract lazy-contract-property))))
(cons name-prop lazy-contract-name)
(cons first-order-prop (λ (ctc) predicate))
(cons stronger-prop stronger-lazy-contract?))))
(define-for-syntax (build-enforcer opt/i opt/info name stx clauses (define-for-syntax (build-enforcer opt/i opt/info name stx clauses
helper-id-var helper-info helper-freev helper-id-var helper-info helper-freev
@ -395,10 +392,7 @@ it around flattened out.
(let ([to-save (append (opt/info-free-vars opt/info) (let ([to-save (append (opt/info-free-vars opt/info)
(lifts-to-save lifts))]) (lifts-to-save lifts))])
(with-syntax ((val (opt/info-val opt/info)) (with-syntax ((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))
(ctc (opt/info-contract opt/info)) (ctc (opt/info-contract opt/info))
(enforcer-id enforcer-id-var) (enforcer-id enforcer-id-var)
(helper-id helper-id-var) (helper-id helper-id-var)
@ -451,13 +445,11 @@ it around flattened out.
(opt-wrap-set w j free-var) (... ...) (opt-wrap-set w j free-var) (... ...)
w)] w)]
[else [else
(raise-contract-error (raise-blame-error
blame
val val
src-info
pos
orig-str
"expected <~a>, got ~e" "expected <~a>, got ~e"
((name-get ctc) ctc) (contract-name ctc)
val)])) val)]))
lifts lifts
superlifts superlifts
@ -469,12 +461,12 @@ it around flattened out.
(define (do-contract-name name/c name/dc list-of-subcontracts fields attrs) (define (do-contract-name name/c name/dc list-of-subcontracts fields attrs)
(cond (cond
[(and (andmap name-pred? list-of-subcontracts) (not attrs)) [(and (andmap contract-struct? list-of-subcontracts) (not attrs))
(apply build-compound-type-name name/c list-of-subcontracts)] (apply build-compound-type-name name/c list-of-subcontracts)]
[else [else
(let ([fields (let ([fields
(map (λ (field ctc) (map (λ (field ctc)
(if (name-pred? ctc) (if (contract? ctc)
(build-compound-type-name field ctc) (build-compound-type-name field ctc)
(build-compound-type-name field '...))) (build-compound-type-name field '...)))
fields fields
@ -490,7 +482,7 @@ it around flattened out.
(list 'and '...)))] (list 'and '...)))]
[else (apply build-compound-type-name name/dc fields)]))])) [else (apply build-compound-type-name name/dc fields)]))]))
(define-struct contract/info (contract pos neg src-info orig-str positive-position?)) (define-struct contract/info (contract blame))
(define-struct opt-contract/info (contract enforcer id)) (define-struct opt-contract/info (contract enforcer id))
;; parents : (listof wrap-parent) ;; parents : (listof wrap-parent)
@ -513,11 +505,9 @@ it around flattened out.
(define (check-synth-info-test stct synth-info contract/info) (define (check-synth-info-test stct synth-info contract/info)
(unless ((synth-info-test synth-info) (synth-info-vals synth-info)) (unless ((synth-info-test synth-info) (synth-info-vals synth-info))
(raise-contract-error (raise-blame-error
(contract/info-blame contract/info)
stct stct
(contract/info-src-info contract/info)
(contract/info-pos contract/info)
(contract/info-orig-str contract/info)
"failed `and' clause, got ~e" stct))) "failed `and' clause, got ~e" stct)))
(define-values (evaluate-attr-prop evaluate-attr-prop-predicate evaluate-attr-prop-accessor) (define-values (evaluate-attr-prop evaluate-attr-prop-predicate evaluate-attr-prop-accessor)
@ -544,14 +534,6 @@ it around flattened out.
(define max-cache-size 5) (define max-cache-size 5)
(define lazy-depth-to-look 5) (define lazy-depth-to-look 5)
(define (check-sub-contract? x y)
(cond
[(and (stronger-pred? x) (stronger-pred? y))
(contract-stronger? x y)]
[(and (procedure? x) (procedure? y))
(procedure-closure-contents-eq? x y)]
[else #f]))
#| #|
test case: test case:
(define-contract-struct s (a b)) (define-contract-struct s (a b))