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]))
(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)))
(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)))
(define rng-ctc-projs (map (λ (x) (contract-late-neg-projection (cdr x))) (->i-rng-ctcs ctc)))
(define indy-rng-ctc-projs (map (λ (x) (contract-late-neg-projection (cdr x)))
(define rng-ctc-projs (map (λ (x) (get/build-late-neg-projection (cdr x))) (->i-rng-ctcs ctc)))
(define indy-rng-ctc-projs (map (λ (x) (get/build-late-neg-projection (cdr x)))
(->i-indy-rng-ctcs ctc)))
(define has-rest (->i-rest ctc))
(define here (->i-here ctc))
@ -1094,12 +1094,12 @@ evaluted left-to-right.)
(raise-argument-error '->i
"chaperone-contract?"
orig-ctc))
(((contract-late-neg-projection ctc) blame) obj neg-party))))
(((get/build-late-neg-projection ctc) blame) obj neg-party))))
(begin-encourage-inline
(define (un-dep orig-ctc obj blame neg-party)
(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)
(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)
(λ (blame)
(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))
(λ (val neg-party)
(unless (list? val)
@ -157,7 +157,7 @@
[else
(λ (blame)
(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))
(λ (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)
(λ (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 specs (base-case->-specs ctc))
(λ (blame)
@ -294,11 +294,11 @@
[rst (in-list (base-case->-rst-ctcs ctc))]
[i (in-naturals)])
(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
(if rst
(append dom+case-nums
(list (cons i (contract-late-neg-projection rst))))
(list (cons i (get/build-late-neg-projection rst))))
dom+case-nums))))
(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 flat? (flat-hash/c? ctc))
(λ (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)))
(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)))
(λ (val neg-party)
(cond

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

@ -1994,7 +1994,7 @@
(define (stronger? this other)
(contract-stronger? ctc other))
(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)
#:stronger stronger?
#:list-contract? (list-contract? ctc))))))
@ -2037,8 +2037,8 @@
(define (if/c-late-neg-proj ctc)
(define predicate (base-if/c-predicate ctc))
(define thn (contract-late-neg-projection (base-if/c-thn ctc)))
(define els (contract-late-neg-projection (base-if/c-els ctc)))
(define thn (get/build-late-neg-projection (base-if/c-thn ctc)))
(define els (get/build-late-neg-projection (base-if/c-els ctc)))
(λ (blame)
(define thn-proj (thn blame))
(define els-proj (els blame))

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

@ -69,7 +69,7 @@
(barrier/c negative? var)))
(define protector
(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)
(unless (procedure? p)

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

@ -260,7 +260,7 @@
(cond
[(indep? 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])))
(define mut-projs
(for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))]
@ -268,7 +268,7 @@
(cond
[(and (indep? subcontract) (mutable? 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])))
(define orig-indy-projs
(for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))]
@ -276,7 +276,7 @@
(cond
[(indep? 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])))
(define orig-mut-indy-projs
(for/list ([subcontract (in-list (base-struct/dc-subcontracts ctc))]
@ -284,7 +284,7 @@
(cond
[(indep? 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])))
(λ (v neg-party)
(cond
@ -339,7 +339,7 @@
'struct/dc
(apply (dep-dep-proc subcontract) dep-args))))
(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)
(cond
[(invariant? subcontract)
@ -589,7 +589,7 @@
(define the-ctc
(coerce-contract 'struct/dc (apply (dep-dep-proc this-subcontract) dep-args)))
(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
(define indy-blame (car blames))
(define proj (car projs))
@ -598,7 +598,7 @@
(coerce-contract
'struct/dc
(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)
(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-late-neg-proj
(contract-late-neg-projection
(get/build-late-neg-projection
(struct-type-property/c-value-contract stpc)))
(λ (input-blame)
(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 val+np-acceptors
(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)
(with-contract-continuation-mark
(cons blame neg-party)
@ -377,12 +377,12 @@
(let ([elem-pos-projs (for/vector #:length (length elem-ctcs)
([c (in-list elem-ctcs)]
[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)))))]
[elem-neg-projs (for/vector #:length (length elem-ctcs)
([c (in-list elem-ctcs)]
[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))
#:swap? #t)))])
(λ (val neg-party)