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

use the correct accessor for subcontracts

Browse Source
This commit is contained in:
Robby Findler 2015-12-22 10:27:36 -06:00
parent 2b10262258
commit d2bf335212
9 changed files with 28 additions and 28 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
racket/collects/racket/contract/private/arr-i.rkt
View File

@ -28,12 +28,12 @@
(provide (rename-out [->i/m ->i])) (provide (rename-out [->i/m ->i]))
(define (build-??-args c-or-i-procedure ctc blame) (define (build-??-args c-or-i-procedure ctc blame)
(define arg-ctc-projs (map (λ (x) (contract-late-neg-projection (->i-arg-contract x))) (define arg-ctc-projs (map (λ (x) (get/build-late-neg-projection (->i-arg-contract x)))
(->i-arg-ctcs ctc))) (->i-arg-ctcs ctc)))
(define indy-arg-ctc-projs (map (λ (x) (contract-late-neg-projection (cdr x))) (define indy-arg-ctc-projs (map (λ (x) (get/build-late-neg-projection (cdr x)))
(->i-indy-arg-ctcs ctc))) (->i-indy-arg-ctcs ctc)))
(define rng-ctc-projs (map (λ (x) (contract-late-neg-projection (cdr x))) (->i-rng-ctcs ctc))) (define rng-ctc-projs (map (λ (x) (get/build-late-neg-projection (cdr x))) (->i-rng-ctcs ctc)))
(define indy-rng-ctc-projs (map (λ (x) (contract-late-neg-projection (cdr x))) (define indy-rng-ctc-projs (map (λ (x) (get/build-late-neg-projection (cdr x)))
(->i-indy-rng-ctcs ctc))) (->i-indy-rng-ctcs ctc)))
(define has-rest (->i-rest ctc)) (define has-rest (->i-rest ctc))
(define here (->i-here ctc)) (define here (->i-here ctc))
@ -1094,12 +1094,12 @@ evaluted left-to-right.)
(raise-argument-error '->i (raise-argument-error '->i
"chaperone-contract?" "chaperone-contract?"
orig-ctc)) orig-ctc))
(((contract-late-neg-projection ctc) blame) obj neg-party)))) (((get/build-late-neg-projection ctc) blame) obj neg-party))))
(begin-encourage-inline (begin-encourage-inline
(define (un-dep orig-ctc obj blame neg-party) (define (un-dep orig-ctc obj blame neg-party)
(let ([ctc (coerce-contract '->i orig-ctc)]) (let ([ctc (coerce-contract '->i orig-ctc)])
(((contract-late-neg-projection ctc) blame) obj neg-party)))) (((get/build-late-neg-projection ctc) blame) obj neg-party))))
(define-for-syntax (mk-used-indy-vars an-istx) (define-for-syntax (mk-used-indy-vars an-istx)
(let ([vars (make-free-identifier-mapping)]) (let ([vars (make-free-identifier-mapping)])

4
racket/collects/racket/contract/private/base.rkt
View File

@ -145,7 +145,7 @@
[(recursive-contract-list-contract? ctc) [(recursive-contract-list-contract? ctc)
(λ (blame) (λ (blame)
(define r-ctc (force-recursive-contract ctc)) (define r-ctc (force-recursive-contract ctc))
(define f (contract-late-neg-projection r-ctc)) (define f (get/build-late-neg-projection r-ctc))
(define blame-known (blame-add-context blame #f)) (define blame-known (blame-add-context blame #f))
(λ (val neg-party) (λ (val neg-party)
(unless (list? val) (unless (list? val)
@ -157,7 +157,7 @@
[else [else
(λ (blame) (λ (blame)
(define r-ctc (force-recursive-contract ctc)) (define r-ctc (force-recursive-contract ctc))
(define f (contract-late-neg-projection r-ctc)) (define f (get/build-late-neg-projection r-ctc))
(define blame-known (blame-add-context blame #f)) (define blame-known (blame-add-context blame #f))
(λ (val neg-party) (λ (val neg-party)
((f blame-known) val neg-party)))])) ((f blame-known) val neg-party)))]))

6
racket/collects/racket/contract/private/case-arrow.rkt
View File

@ -184,7 +184,7 @@
(define (case->-proj wrapper) (define (case->-proj wrapper)
(λ (ctc) (λ (ctc)
(define dom-ctcs+case-nums (get-case->-dom-ctcs+case-nums ctc)) (define dom-ctcs+case-nums (get-case->-dom-ctcs+case-nums ctc))
(define rng-late-neg-ctcs (map contract-late-neg-projection (get-case->-rng-ctcs ctc))) (define rng-late-neg-ctcs (map get/build-late-neg-projection (get-case->-rng-ctcs ctc)))
(define rst-ctcs (base-case->-rst-ctcs ctc)) (define rst-ctcs (base-case->-rst-ctcs ctc))
(define specs (base-case->-specs ctc)) (define specs (base-case->-specs ctc))
(λ (blame) (λ (blame)
@ -294,11 +294,11 @@
[rst (in-list (base-case->-rst-ctcs ctc))] [rst (in-list (base-case->-rst-ctcs ctc))]
[i (in-naturals)]) [i (in-naturals)])
(define dom+case-nums (define dom+case-nums
(map (λ (dom) (cons i (contract-late-neg-projection dom))) doms)) (map (λ (dom) (cons i (get/build-late-neg-projection dom))) doms))
(append acc (append acc
(if rst (if rst
(append dom+case-nums (append dom+case-nums
(list (cons i (contract-late-neg-projection rst)))) (list (cons i (get/build-late-neg-projection rst))))
dom+case-nums)))) dom+case-nums))))
(define (get-case->-rng-ctcs ctc) (define (get-case->-rng-ctcs ctc)

4
racket/collects/racket/contract/private/hash.rkt
View File

@ -194,9 +194,9 @@
(define immutable (base-hash/c-immutable ctc)) (define immutable (base-hash/c-immutable ctc))
(define flat? (flat-hash/c? ctc)) (define flat? (flat-hash/c? ctc))
(λ (blame) (λ (blame)
(define dom-proj ((contract-late-neg-projection (base-hash/c-dom ctc)) (define dom-proj ((get/build-late-neg-projection (base-hash/c-dom ctc))
(blame-add-key-context blame #f))) (blame-add-key-context blame #f)))
(define rng-proj ((contract-late-neg-projection (base-hash/c-rng ctc)) (define rng-proj ((get/build-late-neg-projection (base-hash/c-rng ctc))
(blame-add-value-context blame #f))) (blame-add-value-context blame #f)))
(λ (val neg-party) (λ (val neg-party)
(cond (cond

6
racket/collects/racket/contract/private/misc.rkt
View File

@ -1994,7 +1994,7 @@
(define (stronger? this other) (define (stronger? this other)
(contract-stronger? ctc other)) (contract-stronger? ctc other))
(make-contract #:name name (make-contract #:name name
#:late-neg-projection (contract-late-neg-projection ctc) #:late-neg-projection (get/build-late-neg-projection ctc)
#:first-order (contract-first-order ctc) #:first-order (contract-first-order ctc)
#:stronger stronger? #:stronger stronger?
#:list-contract? (list-contract? ctc)))))) #:list-contract? (list-contract? ctc))))))
@ -2037,8 +2037,8 @@
(define (if/c-late-neg-proj ctc) (define (if/c-late-neg-proj ctc)
(define predicate (base-if/c-predicate ctc)) (define predicate (base-if/c-predicate ctc))
(define thn (contract-late-neg-projection (base-if/c-thn ctc))) (define thn (get/build-late-neg-projection (base-if/c-thn ctc)))
(define els (contract-late-neg-projection (base-if/c-els ctc))) (define els (get/build-late-neg-projection (base-if/c-els ctc)))
(λ (blame) (λ (blame)
(define thn-proj (thn blame)) (define thn-proj (thn blame))
(define els-proj (els blame)) (define els-proj (els blame))

2
racket/collects/racket/contract/private/parametric.rkt
View File

@ -69,7 +69,7 @@
(barrier/c negative? var))) (barrier/c negative? var)))
(define protector (define protector
(apply (polymorphic-contract-body c) instances)) (apply (polymorphic-contract-body c) instances))
(((contract-late-neg-projection protector) blame) p neg-party)) (((get/build-late-neg-projection protector) blame) p neg-party))
(lambda (p neg-party) (lambda (p neg-party)
(unless (procedure? p) (unless (procedure? p)

14
racket/collects/racket/contract/private/struct-dc.rkt
View File

@ -260,7 +260,7 @@
(cond (cond
[(indep? subcontract) [(indep? subcontract)
(define sub-ctc (indep-ctc subcontract)) (define sub-ctc (indep-ctc subcontract))
((contract-late-neg-projection sub-ctc) blame+ctxt)] ((get/build-late-neg-projection sub-ctc) blame+ctxt)]
[else #f]))) [else #f])))
(define mut-projs (define mut-projs
(for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))] (for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))]
@ -268,7 +268,7 @@
(cond (cond
[(and (indep? subcontract) (mutable? subcontract)) [(and (indep? subcontract) (mutable? subcontract))
(define sub-ctc (indep-ctc subcontract)) (define sub-ctc (indep-ctc subcontract))
((contract-late-neg-projection sub-ctc) blame+ctxt)] ((get/build-late-neg-projection sub-ctc) blame+ctxt)]
[else #f]))) [else #f])))
(define orig-indy-projs (define orig-indy-projs
(for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))] (for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))]
@ -276,7 +276,7 @@
(cond (cond
[(indep? subcontract) [(indep? subcontract)
(define sub-ctc (indep-ctc subcontract)) (define sub-ctc (indep-ctc subcontract))
((contract-late-neg-projection sub-ctc) blame+ctxt)] ((get/build-late-neg-projection sub-ctc) blame+ctxt)]
[else #f]))) [else #f])))
(define orig-mut-indy-projs (define orig-mut-indy-projs
(for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))] (for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))]
@ -284,7 +284,7 @@
(cond (cond
[(indep? subcontract) [(indep? subcontract)
(define sub-ctc (indep-ctc subcontract)) (define sub-ctc (indep-ctc subcontract))
((contract-late-neg-projection sub-ctc) blame+ctxt)] ((get/build-late-neg-projection sub-ctc) blame+ctxt)]
[else #f]))) [else #f])))
(λ (v neg-party) (λ (v neg-party)
(cond (cond
@ -339,7 +339,7 @@
'struct/dc 'struct/dc
(apply (dep-dep-proc subcontract) dep-args)))) (apply (dep-dep-proc subcontract) dep-args))))
(when dep-ctc (check-flat/chaperone dep-ctc subcontract)) (when dep-ctc (check-flat/chaperone dep-ctc subcontract))
(define dep-ctc-blame-proj (and dep-ctc (contract-late-neg-projection dep-ctc))) (define dep-ctc-blame-proj (and dep-ctc (get/build-late-neg-projection dep-ctc)))
(define-values (new-chaperone-args new-impersonate-args) (define-values (new-chaperone-args new-impersonate-args)
(cond (cond
[(invariant? subcontract) [(invariant? subcontract)
@ -589,7 +589,7 @@
(define the-ctc (define the-ctc
(coerce-contract 'struct/dc (apply (dep-dep-proc this-subcontract) dep-args))) (coerce-contract 'struct/dc (apply (dep-dep-proc this-subcontract) dep-args)))
(check-flat/chaperone the-ctc subcontract) (check-flat/chaperone the-ctc subcontract)
(((contract-late-neg-projection the-ctc) blame) val neg-party)] (((get/build-late-neg-projection the-ctc) blame) val neg-party)]
[else [else
(define indy-blame (car blames)) (define indy-blame (car blames))
(define proj (car projs)) (define proj (car projs))
@ -598,7 +598,7 @@
(coerce-contract (coerce-contract
'struct/dc 'struct/dc
(apply (dep-dep-proc subcontract) dep-args)))) (apply (dep-dep-proc subcontract) dep-args))))
(define dep-ctc-blame-proj (and dep-ctc (contract-late-neg-projection dep-ctc))) (define dep-ctc-blame-proj (and dep-ctc (get/build-late-neg-projection dep-ctc)))
(when (dep? subcontract) (when (dep? subcontract)
(check-flat/chaperone dep-ctc subcontract)) (check-flat/chaperone dep-ctc subcontract))

2
racket/collects/racket/contract/private/struct-prop.rkt
View File

@ -7,7 +7,7 @@
(define (get-stpc-late-neg-proj stpc) (define (get-stpc-late-neg-proj stpc)
(define get-late-neg-proj (define get-late-neg-proj
(contract-late-neg-projection (get/build-late-neg-projection
(struct-type-property/c-value-contract stpc))) (struct-type-property/c-value-contract stpc)))
(λ (input-blame) (λ (input-blame)
(define blame (blame-add-context input-blame "the struct property value of" #:swap? #t)) (define blame (blame-add-context input-blame "the struct property value of" #:swap? #t))

6
racket/collects/racket/contract/private/vector.rkt
View File

@ -358,7 +358,7 @@
(define blame+ctxt (blame-add-element-of-context blame)) (define blame+ctxt (blame-add-element-of-context blame))
(define val+np-acceptors (define val+np-acceptors
(for/list ([c (in-list (base-vector/c-elems ctc))]) (for/list ([c (in-list (base-vector/c-elems ctc))])
((contract-late-neg-projection c) blame+ctxt))) ((get/build-late-neg-projection c) blame+ctxt)))
(λ (val neg-party) (λ (val neg-party)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) (cons blame neg-party)
@ -377,12 +377,12 @@
(let ([elem-pos-projs (for/vector #:length (length elem-ctcs) (let ([elem-pos-projs (for/vector #:length (length elem-ctcs)
([c (in-list elem-ctcs)] ([c (in-list elem-ctcs)]
[i (in-naturals)]) [i (in-naturals)])
((contract-late-neg-projection c) ((get/build-late-neg-projection c)
(blame-add-context blame (format "the ~a element of" (n->th i)))))] (blame-add-context blame (format "the ~a element of" (n->th i)))))]
[elem-neg-projs (for/vector #:length (length elem-ctcs) [elem-neg-projs (for/vector #:length (length elem-ctcs)
([c (in-list elem-ctcs)] ([c (in-list elem-ctcs)]
[i (in-naturals)]) [i (in-naturals)])
((contract-late-neg-projection c) ((get/build-late-neg-projection c)
(blame-add-context blame (format "the ~a element of" (n->th i)) (blame-add-context blame (format "the ~a element of" (n->th i))
#:swap? #t)))]) #:swap? #t)))])
(λ (val neg-party) (λ (val neg-party)