add contract-pos/neg-doubling and use it in various places
This commit is contained in:
Robby Findler
parent
96b69d0366
commit
ff588f93eb
|
|
@ -2374,6 +2374,43 @@ of the @tech{blame object} and the missing party should be used instead.
|
|||
@history[#:added "6.4.0.4"]
|
||||
}
|
||||
|
||||
@defform[(contract-pos/neg-doubling e1 e2)]{
|
||||
|
||||
Some contract combinators need to build projections for
|
||||
subcontracts with both regular and @racket[blame-swap]ed
|
||||
versions of the blame that they are given in order to check
|
||||
both access and mutations (e.g., @racket[vector/c] and
|
||||
@racket[vectorof]). In the case that such combinators are
|
||||
nested deeply inside each other, there is a potential for an
|
||||
exponential explosion of nested projections being built.
|
||||
|
||||
To avoid that explosion, wrap each of the calls to the
|
||||
blame-accepting portion of the combinator in
|
||||
@racket[contract-pos/neg-doubling]. It returns three values.
|
||||
The first is a boolean, indicating how to interpret the
|
||||
other two results. If the boolean is @racket[#t], then the
|
||||
other two results are the values of @racket[e1] and
|
||||
@racket[e2] and we are not too deep in the nesting. If the
|
||||
boolean is @racket[#f], then we have passed a threshold and
|
||||
it is not safe to evaluate @racket[e1] and @racket[e2] yet,
|
||||
as we are in danger of running into the exponential
|
||||
slowdown. In that case, the last two results are thunks
|
||||
that, when invoked, compute the values of @racket[e1] and
|
||||
@racket[e2].
|
||||
|
||||
As an example, @racket[vectorof] uses
|
||||
@racket[contract-pos/neg-doubling] wrapping its two calls to
|
||||
the blame-accepting part of the projection for its
|
||||
subcontract. When it receives a @racket[#f] as that first
|
||||
boolean, it does not invoke the thunks right away, but waits
|
||||
until the interposition procedure that it attaches to the
|
||||
chaperoned vector is called. Then it invokes them (and caches
|
||||
the result). This delays the construction of the projections
|
||||
until they are actually needed, avoiding the exponential blowup.
|
||||
|
||||
@history[#:added "6.90.0.27"]
|
||||
}
|
||||
|
||||
@subsection{Blame Objects}
|
||||
|
||||
This section describes @deftech{blame objects} and operations on them.
|
||||
|
|
|
|||
|
|
@ -75,6 +75,27 @@
|
|||
'box/c12
|
||||
'(set-box! (contract (box/c integer?) (box 1) 'pos 'neg) 1.5))
|
||||
|
||||
(test/pos-blame
|
||||
'box/c13
|
||||
'(let ()
|
||||
(define N 18)
|
||||
|
||||
(define c
|
||||
(for/fold ([c (-> integer? integer?)])
|
||||
([i (in-range N)])
|
||||
(box/c c)))
|
||||
|
||||
(define val
|
||||
(for/fold ([val 5])
|
||||
([i (in-range N)])
|
||||
(box val)))
|
||||
|
||||
(define cval (contract c val 'pos 'neg))
|
||||
|
||||
(for/fold ([val cval])
|
||||
([i (in-range N)])
|
||||
(unbox val))))
|
||||
|
||||
;; contract-stronger? tests
|
||||
(contract-eval '(require (only-in racket/contract/combinator contract-stronger?)))
|
||||
|
||||
|
|
|
|||
|
|
@ -1593,6 +1593,31 @@
|
|||
(inherit-field f)
|
||||
(define/public (m) f))])
|
||||
(send (new d%) m)))
|
||||
|
||||
(test/pos-blame
|
||||
'inherit-field-lots-of-wrappers
|
||||
'(let ()
|
||||
(define N 40)
|
||||
|
||||
(define c
|
||||
(for/fold ([c (-> integer? integer?)])
|
||||
([i (in-range N)])
|
||||
(class/c (inherit-field [fld c]))))
|
||||
|
||||
(define val
|
||||
(for/fold ([val 5])
|
||||
([i (in-range N)])
|
||||
(class object% (field [fld val]) (super-new))))
|
||||
|
||||
(define cval (contract c val 'pos 'neg))
|
||||
|
||||
(for/fold ([val cval])
|
||||
([i (in-range N)])
|
||||
(send (new (class val
|
||||
(super-new)
|
||||
(inherit-field fld)
|
||||
(define/public (m) fld)))
|
||||
m))))
|
||||
|
||||
(test/spec-passed
|
||||
'class/c-higher-order-override-1
|
||||
|
|
@ -2087,6 +2112,49 @@
|
|||
'somethingelse1 'somethingelse2)
|
||||
'pos 'neg)
|
||||
[x 2]))
|
||||
|
||||
(test/pos-blame
|
||||
'class/c-deep.1
|
||||
'(let ()
|
||||
(define N 40)
|
||||
|
||||
(define c
|
||||
(for/fold ([c (-> integer? integer?)])
|
||||
([i (in-range N)])
|
||||
(class/c (field [fld c]))))
|
||||
|
||||
(define v
|
||||
(for/fold ([v 1])
|
||||
([i (in-range N)])
|
||||
(class object%
|
||||
(field [fld v])
|
||||
(super-new))))
|
||||
|
||||
(let loop ([v (contract c v 'pos 'neg)])
|
||||
(loop (get-field fld (new v))))))
|
||||
|
||||
(test/neg-blame
|
||||
'class/c-deep.2
|
||||
'(let ()
|
||||
(define N 40)
|
||||
|
||||
(define c
|
||||
(for/fold ([c (-> integer? integer?)])
|
||||
([i (in-range N)])
|
||||
(class/c (field [fld c]))))
|
||||
|
||||
(define v
|
||||
(for/fold ([v 1])
|
||||
([i (in-range N)])
|
||||
(class object%
|
||||
(field [fld v])
|
||||
(super-new))))
|
||||
|
||||
(let loop ([v (contract c v 'pos 'neg)]
|
||||
[i N])
|
||||
(cond
|
||||
[(= i 1) (set-field! fld (new v) 'not-a-proc)]
|
||||
[else (loop (get-field fld (new v)) (- i 1))]))))
|
||||
|
||||
(test/spec-passed/result
|
||||
'class-field-accessor1
|
||||
|
|
|
|||
|
|
@ -235,6 +235,21 @@
|
|||
c-h))
|
||||
#t)
|
||||
|
||||
(test/pos-blame
|
||||
'hash/c18
|
||||
'(let ()
|
||||
(define N 40)
|
||||
(define c
|
||||
(for/fold ([c (-> integer? integer?)])
|
||||
([i (in-range N)])
|
||||
(hash/c c integer?)))
|
||||
(define h
|
||||
(for/fold ([h 0])
|
||||
([i (in-range N)])
|
||||
(hash h i)))
|
||||
(immutable? h)
|
||||
|
||||
(void (contract c h 'pos 'neg))))
|
||||
|
||||
(test/pos-blame
|
||||
'hash/dc1
|
||||
|
|
|
|||
|
|
@ -283,6 +283,51 @@
|
|||
|
||||
(send x3 p)))
|
||||
|
||||
(test/pos-blame
|
||||
'object/c-lots-of-wrapping.1
|
||||
'(let ()
|
||||
(define N 40)
|
||||
|
||||
(define c
|
||||
(for/fold ([c (-> integer? integer?)])
|
||||
([i (in-range N)])
|
||||
(object/c (field [fld c]))))
|
||||
|
||||
(define o
|
||||
(for/fold ([v 'not-a-proc])
|
||||
([i (in-range N)])
|
||||
(new
|
||||
(class object%
|
||||
(field [fld v])
|
||||
(super-new)))))
|
||||
|
||||
(let loop ([o (contract c o 'pos 'neg)])
|
||||
(loop (get-field fld o)))))
|
||||
|
||||
(test/neg-blame
|
||||
'object/c-lots-of-wrapping.2
|
||||
'(let ()
|
||||
(define N 40)
|
||||
|
||||
(define c
|
||||
(for/fold ([c (-> integer? integer?)])
|
||||
([i (in-range N)])
|
||||
(object/c (field [fld c]))))
|
||||
|
||||
(define o
|
||||
(for/fold ([v add1])
|
||||
([i (in-range N)])
|
||||
(new
|
||||
(class object%
|
||||
(field [fld v])
|
||||
(super-new)))))
|
||||
|
||||
(let loop ([o (contract c o 'pos 'neg)]
|
||||
[i N])
|
||||
(cond
|
||||
[(= i 1) (set-field! fld o 'not-a-proc)]
|
||||
[else (loop (get-field fld o) (- i 1))]))))
|
||||
|
||||
(test/spec-passed
|
||||
'object/c-just-check-existence
|
||||
'(contract (object/c m)
|
||||
|
|
|
|||
|
|
@ -86,6 +86,42 @@
|
|||
'(contract (vectorof integer? #:flat? #t)
|
||||
(vector-immutable 11)
|
||||
'pos 'neg))
|
||||
|
||||
(test/pos-blame
|
||||
'vectorof13
|
||||
'(let ()
|
||||
(define N 40)
|
||||
(define cv
|
||||
(contract (for/fold ([c (-> integer? integer?)])
|
||||
([i (in-range N)])
|
||||
(vectorof c))
|
||||
(for/fold ([v 'not-a-procedure])
|
||||
([i (in-range N)])
|
||||
(vector v))
|
||||
'pos 'neg))
|
||||
(let loop ([cv cv])
|
||||
(loop (vector-ref cv 0)))))
|
||||
|
||||
(test/neg-blame
|
||||
'vectorof14
|
||||
'(let ()
|
||||
(define N 40)
|
||||
(define cv
|
||||
(contract (for/fold ([c (-> integer? integer?)])
|
||||
([i (in-range N)])
|
||||
(vectorof c))
|
||||
(for/fold ([v add1])
|
||||
([i (in-range N)])
|
||||
(vector v))
|
||||
'pos 'neg))
|
||||
(let loop ([cv cv]
|
||||
[i N])
|
||||
(cond
|
||||
[(= i 1)
|
||||
(vector-set! cv 0 'not-a-procedure)]
|
||||
[else
|
||||
(loop (vector-ref cv 0)
|
||||
(- i 1))]))))
|
||||
|
||||
(test/spec-passed
|
||||
'vector/c1
|
||||
|
|
@ -126,6 +162,57 @@
|
|||
(λ (vec i v) v))])
|
||||
(vector-set! (contract (vector/c integer?) v 'pos 'neg)
|
||||
0 #f)))
|
||||
|
||||
(test/pos-blame
|
||||
'vector/c7
|
||||
'(let ()
|
||||
(define N 40)
|
||||
(define cv
|
||||
(contract (for/fold ([c (-> integer? integer?)])
|
||||
([i (in-range N)])
|
||||
(vector/c c))
|
||||
(for/fold ([v 'not-a-procedure])
|
||||
([i (in-range N)])
|
||||
(vector v))
|
||||
'pos 'neg))
|
||||
(let loop ([cv cv])
|
||||
(loop (vector-ref cv 0)))))
|
||||
|
||||
(test/pos-blame
|
||||
'vector/c8
|
||||
'(let ()
|
||||
(define N 40)
|
||||
(define cv
|
||||
(contract (for/fold ([c (-> integer? integer?)])
|
||||
([i (in-range N)])
|
||||
(vector/c c))
|
||||
(for/fold ([v 'not-a-procedure])
|
||||
([i (in-range N)])
|
||||
(vector-immutable v))
|
||||
'pos 'neg))
|
||||
(let loop ([cv cv])
|
||||
(loop (vector-ref cv 0)))))
|
||||
|
||||
(test/neg-blame
|
||||
'vector/c9
|
||||
'(let ()
|
||||
(define N 40)
|
||||
(define cv
|
||||
(contract (for/fold ([c (-> integer? integer?)])
|
||||
([i (in-range N)])
|
||||
(vector/c c))
|
||||
(for/fold ([v add1])
|
||||
([i (in-range N)])
|
||||
(vector v))
|
||||
'pos 'neg))
|
||||
(let loop ([cv cv]
|
||||
[i N])
|
||||
(cond
|
||||
[(= i 1)
|
||||
(vector-set! cv 0 'not-a-procedure)]
|
||||
[else
|
||||
(loop (vector-ref cv 0)
|
||||
(- i 1))]))))
|
||||
|
||||
(test/pos-blame
|
||||
'vector/c7
|
||||
|
|
|
|||
|
|
@ -105,7 +105,9 @@
|
|||
[-make-flat-contract make-flat-contract]
|
||||
[-build-chaperone-contract-property build-chaperone-contract-property]
|
||||
[-build-flat-contract-property build-flat-contract-property])
|
||||
skip-projection-wrapper?)
|
||||
skip-projection-wrapper?
|
||||
|
||||
contract-pos/neg-doubling)
|
||||
|
||||
(define skip-projection-wrapper? (make-parameter #f))
|
||||
|
||||
|
|
|
|||
|
|
@ -137,29 +137,45 @@
|
|||
(define r-vfp (get/build-late-neg-projection elem-r-ctc))
|
||||
(λ (blame)
|
||||
(define box-blame (add-box-context blame))
|
||||
(define pos-elem-r-proj (r-vfp box-blame))
|
||||
(define neg-elem-w-proj (w-vfp (blame-swap box-blame)))
|
||||
(λ (val neg-party)
|
||||
(define blame+neg-party (cons blame neg-party))
|
||||
(cond
|
||||
[(check-box/c-np ctc val blame)
|
||||
=>
|
||||
(λ (f) (f neg-party))]
|
||||
[else
|
||||
(if (and (immutable? val) (not (chaperone? val)))
|
||||
(box-immutable (pos-elem-r-proj (unbox val) neg-party))
|
||||
(chaperone/impersonate-box
|
||||
val
|
||||
(λ (b v)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(pos-elem-r-proj v neg-party)))
|
||||
(λ (b v)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(neg-elem-w-proj v neg-party)))
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame (blame-add-missing-party blame neg-party)))])))))
|
||||
(define-values (filled? maybe-pos-elem-r-proj maybe-neg-elem-w-proj)
|
||||
(contract-pos/neg-doubling (r-vfp box-blame)
|
||||
(w-vfp (blame-swap box-blame))))
|
||||
(define (make-val-np/proc pos-elem-r-proj neg-elem-w-proj)
|
||||
(λ (val neg-party)
|
||||
(define blame+neg-party (cons blame neg-party))
|
||||
(cond
|
||||
[(check-box/c-np ctc val blame)
|
||||
=>
|
||||
(λ (f) (f neg-party))]
|
||||
[else
|
||||
(if (and (immutable? val) (not (chaperone? val)))
|
||||
(box-immutable (pos-elem-r-proj (unbox val) neg-party))
|
||||
(chaperone/impersonate-box
|
||||
val
|
||||
(λ (b v)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(pos-elem-r-proj v neg-party)))
|
||||
(λ (b v)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(neg-elem-w-proj v neg-party)))
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame (blame-add-missing-party blame neg-party)))])))
|
||||
(cond
|
||||
[filled?
|
||||
(make-val-np/proc maybe-pos-elem-r-proj maybe-neg-elem-w-proj)]
|
||||
[else
|
||||
(define tc (make-thread-cell #f))
|
||||
(λ (val neg-party)
|
||||
(cond
|
||||
[(thread-cell-ref tc)
|
||||
=>
|
||||
(λ (f) (f val neg-party))]
|
||||
[else
|
||||
(define proc (make-val-np/proc (maybe-pos-elem-r-proj) (maybe-neg-elem-w-proj)))
|
||||
(thread-cell-set! tc proc)
|
||||
(proc val neg-party)]))]))))
|
||||
|
||||
(define-struct (chaperone-box/c base-box/c) ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
|
|
|
|||
|
|
@ -84,7 +84,9 @@
|
|||
n->th
|
||||
|
||||
false/c-contract
|
||||
true/c-contract)
|
||||
true/c-contract
|
||||
|
||||
contract-pos/neg-doubling)
|
||||
|
||||
(define (contract-custom-write-property-proc stct port mode)
|
||||
(define (write-prefix)
|
||||
|
|
@ -877,3 +879,20 @@
|
|||
[(2) "nd"]
|
||||
[(3) "rd"]
|
||||
[else "th"])))
|
||||
|
||||
|
||||
(define-syntax-rule
|
||||
(contract-pos/neg-doubling e1 e2)
|
||||
(contract-pos/neg-doubling/proc (λ () e1) (λ () e2)))
|
||||
(define doubling-cm-key (gensym 'racket/contract-doubling-mark))
|
||||
(define (contract-pos/neg-doubling/proc t1 t2)
|
||||
(define depth
|
||||
(or (continuation-mark-set-first (current-continuation-marks)
|
||||
doubling-cm-key)
|
||||
0))
|
||||
(cond
|
||||
[(> depth 5)
|
||||
(values #f t1 t2)]
|
||||
[else
|
||||
(with-continuation-mark doubling-cm-key (+ depth 1)
|
||||
(values #t (t1) (t2)))]))
|
||||
|
|
@ -81,9 +81,6 @@
|
|||
;; ... --> boolean
|
||||
;; returns #t when it called raise-blame-error, #f otherwise
|
||||
(define (check-hash/c dom-ctc immutable flat? val blame neg-party)
|
||||
;(define dom-ctc (base-hash/c-dom ctc))
|
||||
;(define immutable (base-hash/c-immutable ctc))
|
||||
;(define flat? (flat-hash/c? ctc))
|
||||
(cond
|
||||
[(hash? val)
|
||||
(cond
|
||||
|
|
@ -215,18 +212,46 @@
|
|||
(define dom-proc (get/build-late-neg-projection dom-ctc))
|
||||
(define rng-proc (get/build-late-neg-projection (base-hash/c-rng ctc)))
|
||||
(λ (blame)
|
||||
(define pos-dom-proj (dom-proc (blame-add-key-context blame #f)))
|
||||
(define neg-dom-proj (dom-proc (blame-add-key-context blame #t)))
|
||||
(define pos-rng-proj (rng-proc (blame-add-value-context blame #f)))
|
||||
(define neg-rng-proj (rng-proc (blame-add-value-context blame #t)))
|
||||
(λ (val neg-party)
|
||||
(cond
|
||||
[(check-hash/c dom-ctc immutable flat? val blame neg-party)
|
||||
val]
|
||||
[else
|
||||
(handle-the-hash val neg-party
|
||||
pos-dom-proj neg-dom-proj (λ (v) pos-rng-proj) (λ (v) neg-rng-proj)
|
||||
chaperone-or-impersonate-hash ctc blame)])))))
|
||||
(define-values (dom-filled? maybe-pos-dom-proj maybe-neg-dom-proj)
|
||||
(contract-pos/neg-doubling (dom-proc (blame-add-key-context blame #f))
|
||||
(dom-proc (blame-add-key-context blame #t))))
|
||||
(define-values (rng-filled? maybe-pos-rng-proj maybe-neg-rng-proj)
|
||||
(contract-pos/neg-doubling (rng-proc (blame-add-value-context blame #f))
|
||||
(rng-proc (blame-add-value-context blame #t))))
|
||||
(cond
|
||||
[(and dom-filled? rng-filled?)
|
||||
(λ (val neg-party)
|
||||
(cond
|
||||
[(check-hash/c dom-ctc immutable flat? val blame neg-party)
|
||||
val]
|
||||
[else
|
||||
(handle-the-hash val neg-party
|
||||
maybe-pos-dom-proj maybe-neg-dom-proj
|
||||
(λ (v) maybe-pos-rng-proj) (λ (v) maybe-neg-rng-proj)
|
||||
chaperone-or-impersonate-hash ctc blame)]))]
|
||||
[else
|
||||
(define tc (make-thread-cell #f))
|
||||
(λ (val neg-party)
|
||||
(define-values (pos-dom-proj neg-dom-proj pos-rng-proj neg-rng-proj)
|
||||
(cond
|
||||
[(thread-cell-ref tc)
|
||||
=>
|
||||
(λ (v) (values (vector-ref v 1) (vector-ref v 2) (vector-ref v 3) (vector-ref v 4)))]
|
||||
[else
|
||||
(define pos-dom-proj (maybe-pos-dom-proj))
|
||||
(define neg-dom-proj (maybe-neg-dom-proj))
|
||||
(define pos-rng-proj (maybe-pos-rng-proj))
|
||||
(define neg-rng-proj (maybe-neg-rng-proj))
|
||||
(thread-cell-set! tc (vector pos-dom-proj neg-dom-proj pos-rng-proj neg-rng-proj))
|
||||
(values pos-dom-proj neg-dom-proj pos-rng-proj neg-rng-proj)]))
|
||||
(cond
|
||||
[(check-hash/c dom-ctc immutable flat? val blame neg-party)
|
||||
val]
|
||||
[else
|
||||
(handle-the-hash val neg-party
|
||||
pos-dom-proj neg-dom-proj
|
||||
(λ (v) pos-rng-proj) (λ (v) neg-rng-proj)
|
||||
chaperone-or-impersonate-hash ctc blame)]))]))))
|
||||
|
||||
(define (blame-add-key-context blame swap?) (blame-add-context blame "the keys of" #:swap? swap?))
|
||||
(define (blame-add-value-context blame swap?) (blame-add-context blame "the values of" #:swap? swap?))
|
||||
|
|
|
|||
|
|
@ -147,7 +147,7 @@
|
|||
|
||||
(define (blame-add-element-of-context blame #:swap? [swap? #f])
|
||||
(blame-add-context blame "an element of" #:swap? swap?))
|
||||
|
||||
|
||||
(define (vectorof-late-neg-ho-projection chaperone-or-impersonate-vector)
|
||||
(λ (ctc)
|
||||
(define elem-ctc (base-vectorof-elem ctc))
|
||||
|
|
@ -158,20 +158,54 @@
|
|||
(define pos-blame (blame-add-element-of-context blame))
|
||||
(define neg-blame (blame-add-element-of-context blame #:swap? #t))
|
||||
(define vfp (get/build-late-neg-projection elem-ctc))
|
||||
(define elem-pos-proj (vfp pos-blame))
|
||||
(define elem-neg-proj (vfp neg-blame))
|
||||
(define checked-ref (λ (neg-party)
|
||||
(define blame+neg-party (cons pos-blame neg-party))
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(elem-pos-proj val neg-party)))))
|
||||
(define checked-set (λ (neg-party)
|
||||
(define blame+neg-party (cons neg-blame neg-party))
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(elem-neg-proj val neg-party)))))
|
||||
(define-values (filled? elem-pos-proj elem-neg-proj)
|
||||
(contract-pos/neg-doubling (vfp pos-blame) (vfp neg-blame)))
|
||||
(define-values (checked-ref checked-set)
|
||||
(cond
|
||||
[filled?
|
||||
(define checked-ref (λ (neg-party)
|
||||
(define blame+neg-party (cons pos-blame neg-party))
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(elem-pos-proj val neg-party)))))
|
||||
(define checked-set (λ (neg-party)
|
||||
(define blame+neg-party (cons neg-blame neg-party))
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(elem-neg-proj val neg-party)))))
|
||||
(values checked-ref checked-set)]
|
||||
[else
|
||||
(define ref-tc (make-thread-cell #f))
|
||||
(define set-tc (make-thread-cell #f))
|
||||
(define checked-ref (λ (neg-party)
|
||||
(define blame+neg-party (cons pos-blame neg-party))
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(define real-elem-pos-proj
|
||||
(cond
|
||||
[(thread-cell-ref ref-tc) => values]
|
||||
[else
|
||||
(define real-elem-pos-proj (elem-pos-proj))
|
||||
(thread-cell-set! ref-tc real-elem-pos-proj)
|
||||
real-elem-pos-proj]))
|
||||
(real-elem-pos-proj val neg-party)))))
|
||||
(define checked-set (λ (neg-party)
|
||||
(define blame+neg-party (cons neg-blame neg-party))
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(define real-elem-neg-proj
|
||||
(cond
|
||||
[(thread-cell-ref set-tc) => values]
|
||||
[else
|
||||
(define real-elem-neg-proj (elem-neg-proj))
|
||||
(thread-cell-set! set-tc real-elem-neg-proj)
|
||||
real-elem-neg-proj]))
|
||||
(real-elem-neg-proj val neg-party)))))
|
||||
(values checked-ref checked-set)]))
|
||||
(cond
|
||||
[(flat-contract? elem-ctc)
|
||||
(define p? (flat-contract-predicate elem-ctc))
|
||||
|
|
@ -181,35 +215,39 @@
|
|||
(check val raise-blame #f)
|
||||
;; avoid traversing large vectors
|
||||
;; unless `eager` is specified
|
||||
(if (and (or (equal? eager #t)
|
||||
(and eager (<= (vector-length val) eager)))
|
||||
(immutable? val)
|
||||
(not (chaperone? val)))
|
||||
(begin (for ([e (in-vector val)])
|
||||
(unless (p? e)
|
||||
(elem-pos-proj e neg-party)))
|
||||
val)
|
||||
(chaperone-or-impersonate-vector
|
||||
val
|
||||
(checked-ref neg-party)
|
||||
(checked-set neg-party)
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame (blame-add-missing-party blame neg-party))))]
|
||||
(cond
|
||||
[(and (or (equal? eager #t)
|
||||
(and eager (<= (vector-length val) eager)))
|
||||
(immutable? val)
|
||||
(not (chaperone? val)))
|
||||
(for ([e (in-vector val)])
|
||||
(unless (p? e)
|
||||
(elem-pos-proj e neg-party)))
|
||||
val]
|
||||
[else
|
||||
(chaperone-or-impersonate-vector
|
||||
val
|
||||
(checked-ref neg-party)
|
||||
(checked-set neg-party)
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame (blame-add-missing-party blame neg-party))]))]
|
||||
[else
|
||||
(λ (val neg-party)
|
||||
(λ (val neg-party)
|
||||
(define (raise-blame val . args)
|
||||
(apply raise-blame-error blame #:missing-party neg-party val args))
|
||||
(check val raise-blame #f)
|
||||
(if (and (immutable? val) (not (chaperone? val)))
|
||||
(vector->immutable-vector
|
||||
(for/vector #:length (vector-length val) ([e (in-vector val)])
|
||||
(elem-pos-proj e neg-party)))
|
||||
(chaperone-or-impersonate-vector
|
||||
val
|
||||
(checked-ref neg-party)
|
||||
(checked-set neg-party)
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame (blame-add-missing-party blame neg-party))))]))))
|
||||
(cond
|
||||
[(and (immutable? val) (not (chaperone? val)))
|
||||
(vector->immutable-vector
|
||||
(for/vector #:length (vector-length val) ([e (in-vector val)])
|
||||
(elem-pos-proj e neg-party)))]
|
||||
[else
|
||||
(chaperone-or-impersonate-vector
|
||||
val
|
||||
(checked-ref neg-party)
|
||||
(checked-set neg-party)
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame (blame-add-missing-party blame neg-party))]))]))))
|
||||
|
||||
(define-values (prop:neg-blame-party prop:neg-blame-party? prop:neg-blame-party-get)
|
||||
(make-impersonator-property 'prop:neg-blame-party))
|
||||
|
|
@ -250,7 +288,10 @@
|
|||
'racket/contract:contract
|
||||
(vector this-one (list #'vecof) null))))]))
|
||||
|
||||
(define/subexpression-pos-prop (vectorof c #:immutable [immutable 'dont-care] #:flat? [flat? #f] #:eager [eager #t])
|
||||
(define/subexpression-pos-prop (vectorof c
|
||||
#:immutable [immutable 'dont-care]
|
||||
#:flat? [flat? #f]
|
||||
#:eager [eager #t])
|
||||
(define ctc
|
||||
(if flat?
|
||||
(coerce-flat-contract 'vectorof c)
|
||||
|
|
@ -398,37 +439,71 @@
|
|||
(let ([elem-ctcs (base-vector/c-elems ctc)]
|
||||
[immutable (base-vector/c-immutable ctc)])
|
||||
(λ (blame)
|
||||
(let ([elem-pos-projs (for/vector #:length (length elem-ctcs)
|
||||
([c (in-list elem-ctcs)]
|
||||
[i (in-naturals)])
|
||||
((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)])
|
||||
((get/build-late-neg-projection c)
|
||||
(blame-add-context blame (format "the ~a element of" (n->th i))
|
||||
#:swap? #t)))])
|
||||
(λ (val neg-party)
|
||||
(check-vector/c ctc val blame neg-party)
|
||||
(define blame+neg-party (cons blame neg-party))
|
||||
(if (and (immutable? val) (not (chaperone? val)))
|
||||
(apply vector-immutable
|
||||
(for/list ([e (in-vector val)]
|
||||
[i (in-naturals)])
|
||||
((vector-ref elem-pos-projs i) e neg-party)))
|
||||
(vector-wrapper
|
||||
val
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
((vector-ref elem-pos-projs i) val neg-party)))
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
((vector-ref elem-neg-projs i) val neg-party)))
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame blame))))))))
|
||||
(define-values (filled? maybe-elem-pos-projs maybe-elem-neg-projs)
|
||||
(contract-pos/neg-doubling
|
||||
(for/vector #:length (length elem-ctcs)
|
||||
([c (in-list elem-ctcs)]
|
||||
[i (in-naturals)])
|
||||
((get/build-late-neg-projection c)
|
||||
(blame-add-context blame (format "the ~a element of" (n->th i)))))
|
||||
(for/vector #:length (length elem-ctcs)
|
||||
([c (in-list elem-ctcs)]
|
||||
[i (in-naturals)])
|
||||
((get/build-late-neg-projection c)
|
||||
(blame-add-context blame (format "the ~a element of" (n->th i))
|
||||
#:swap? #t)))))
|
||||
(cond
|
||||
[filled?
|
||||
(λ (val neg-party)
|
||||
(check-vector/c ctc val blame neg-party)
|
||||
(define blame+neg-party (cons blame neg-party))
|
||||
(if (and (immutable? val) (not (chaperone? val)))
|
||||
(apply vector-immutable
|
||||
(for/list ([e (in-vector val)]
|
||||
[i (in-naturals)])
|
||||
((vector-ref maybe-elem-pos-projs i) e neg-party)))
|
||||
(vector-wrapper
|
||||
val
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
((vector-ref maybe-elem-pos-projs i) val neg-party)))
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
((vector-ref maybe-elem-neg-projs i) val neg-party)))
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame blame)))]
|
||||
[else
|
||||
(define pos-tc (make-thread-cell #f))
|
||||
(define neg-tc (make-thread-cell #f))
|
||||
(define (get-projs tc get-ele-projs)
|
||||
(cond
|
||||
[(thread-cell-ref tc) => values]
|
||||
[else
|
||||
(define projs (get-ele-projs))
|
||||
(thread-cell-set! tc projs)
|
||||
projs]))
|
||||
(λ (val neg-party)
|
||||
(check-vector/c ctc val blame neg-party)
|
||||
(define blame+neg-party (cons blame neg-party))
|
||||
(if (and (immutable? val) (not (chaperone? val)))
|
||||
(apply vector-immutable
|
||||
(for/list ([e (in-vector val)]
|
||||
[i (in-naturals)])
|
||||
((vector-ref (get-projs pos-tc maybe-elem-pos-projs) i) e neg-party)))
|
||||
(vector-wrapper
|
||||
val
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
((vector-ref (get-projs pos-tc maybe-elem-pos-projs) i) val neg-party)))
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
((vector-ref (get-projs neg-tc maybe-elem-neg-projs) i) val neg-party)))
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame blame)))])))))
|
||||
|
||||
(define-struct (chaperone-vector/c base-vector/c) ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
|
|
|
|||
|
|
@ -177,27 +177,50 @@
|
|||
[c (in-list (class/c-method-contracts ctc))])
|
||||
(and c
|
||||
((contract-late-neg-projection c) (blame-add-method-context blame name)))))
|
||||
|
||||
(define external-field-projections
|
||||
(for/list ([f (in-list (class/c-fields ctc))]
|
||||
[c (in-list (class/c-field-contracts ctc))])
|
||||
(define pos-blame (blame-add-field-context blame f #:swap? #f))
|
||||
(define neg-blame (blame-add-field-context blame f #:swap? #t))
|
||||
(and c
|
||||
(let ([p-pos ((contract-late-neg-projection c)
|
||||
pos-blame)]
|
||||
[p-neg ((contract-late-neg-projection c)
|
||||
neg-blame)])
|
||||
(cons (lambda (x pos-party)
|
||||
(define blame+pos-party (cons pos-blame pos-party))
|
||||
(with-contract-continuation-mark
|
||||
blame+pos-party
|
||||
(cond
|
||||
[c
|
||||
(define-values (filled? maybe-p-pos maybe-p-neg)
|
||||
(contract-pos/neg-doubling ((contract-late-neg-projection c) pos-blame)
|
||||
((contract-late-neg-projection c) neg-blame)))
|
||||
(cond
|
||||
[filled?
|
||||
(cons (lambda (x pos-party)
|
||||
(define blame+pos-party (cons pos-blame pos-party))
|
||||
(with-contract-continuation-mark
|
||||
blame+pos-party
|
||||
(maybe-p-pos x pos-party)))
|
||||
(lambda (x neg-party)
|
||||
(define blame+neg-party (cons neg-blame neg-party))
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(maybe-p-neg x neg-party))))]
|
||||
[else
|
||||
(define tc-pos (make-thread-cell #f))
|
||||
(define tc-neg (make-thread-cell #f))
|
||||
(cons (lambda (x pos-party)
|
||||
(define blame+pos-party (cons pos-blame pos-party))
|
||||
(with-contract-continuation-mark
|
||||
blame+pos-party
|
||||
(define p-pos (or (thread-cell-ref tc-pos)
|
||||
(let ([p-pos (maybe-p-pos)])
|
||||
(thread-cell-set! tc-pos p-pos)
|
||||
p-pos)))
|
||||
(p-pos x pos-party)))
|
||||
(lambda (x neg-party)
|
||||
(define blame+neg-party (cons neg-blame neg-party))
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(p-neg x neg-party))))))))
|
||||
(lambda (x neg-party)
|
||||
(define blame+neg-party (cons neg-blame neg-party))
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(define p-neg (or (thread-cell-ref tc-neg)
|
||||
(let ([p-neg (maybe-p-neg)])
|
||||
(thread-cell-set! tc-neg p-neg)
|
||||
p-neg)))
|
||||
(p-neg x neg-party))))])]
|
||||
[else #f])))
|
||||
|
||||
;; zip the inits and contracts together for ordered selection
|
||||
(define inits+contracts
|
||||
|
|
@ -439,20 +462,52 @@
|
|||
(define internal-field-projections
|
||||
(for/list ([f (in-list (internal-class/c-inherit-fields internal-ctc))]
|
||||
[c (in-list (internal-class/c-inherit-field-contracts internal-ctc))])
|
||||
(and c
|
||||
(let* ([blame-acceptor (contract-late-neg-projection c)]
|
||||
[p-pos (blame-acceptor blame)]
|
||||
[p-neg (blame-acceptor bswap)])
|
||||
(cons (lambda (x pos-party)
|
||||
(define blame+pos-party (cons blame pos-party))
|
||||
(with-contract-continuation-mark
|
||||
blame+pos-party
|
||||
(cond
|
||||
[c
|
||||
(define blame-acceptor (contract-late-neg-projection c))
|
||||
(define-values (filled? maybe-p-pos maybe-p-neg)
|
||||
(contract-pos/neg-doubling (blame-acceptor blame)
|
||||
(blame-acceptor bswap)))
|
||||
(cond
|
||||
[filled?
|
||||
(cons (lambda (x pos-party)
|
||||
(define blame+pos-party (cons blame pos-party))
|
||||
(with-contract-continuation-mark
|
||||
blame+pos-party
|
||||
(maybe-p-pos x pos-party)))
|
||||
(lambda (x neg-party)
|
||||
(define blame+neg-party (cons blame neg-party))
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(maybe-p-neg x neg-party))))]
|
||||
[else
|
||||
(define tc-pos (make-thread-cell #f))
|
||||
(define tc-neg (make-thread-cell #f))
|
||||
(cons (lambda (x pos-party)
|
||||
(define blame+pos-party (cons blame pos-party))
|
||||
(with-contract-continuation-mark
|
||||
blame+pos-party
|
||||
(define p-pos
|
||||
(cond
|
||||
[(thread-cell-ref tc-pos) => values]
|
||||
[else
|
||||
(define p-pos (maybe-p-pos))
|
||||
(thread-cell-set! tc-pos p-pos)
|
||||
p-pos]))
|
||||
(p-pos x pos-party)))
|
||||
(lambda (x neg-party)
|
||||
(define blame+neg-party (cons blame neg-party))
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(p-neg x neg-party))))))))
|
||||
(lambda (x neg-party)
|
||||
(define blame+neg-party (cons blame neg-party))
|
||||
(with-contract-continuation-mark
|
||||
blame+neg-party
|
||||
(define p-neg
|
||||
(cond
|
||||
[(thread-cell-ref tc-neg) => values]
|
||||
[else
|
||||
(define p-neg (maybe-p-neg))
|
||||
(thread-cell-set! tc-neg p-neg)
|
||||
p-neg]))
|
||||
(p-neg x neg-party))))])]
|
||||
[else #f])))
|
||||
|
||||
(define override-projections
|
||||
(for/list ([m (in-list (internal-class/c-overrides internal-ctc))]
|
||||
|
|
@ -1602,16 +1657,24 @@
|
|||
((contract-late-neg-projection c) blame*)]
|
||||
[else #f])))
|
||||
|
||||
(define pos/neg-field-projs
|
||||
(for/list ([f (in-list fields)]
|
||||
[c (in-list field-contracts)])
|
||||
(cond
|
||||
[(just-check-existence? c) #f]
|
||||
[else
|
||||
(define prj (contract-late-neg-projection c))
|
||||
(vector
|
||||
(prj (blame-add-field-context blame f #:swap? #f))
|
||||
(prj (blame-add-field-context blame f #:swap? #t)))])))
|
||||
(define-values (filled? maybe-pos-field-projs maybe-neg-field-projs)
|
||||
(contract-pos/neg-doubling
|
||||
(for/list ([f (in-list fields)]
|
||||
[c (in-list field-contracts)])
|
||||
(cond
|
||||
[(just-check-existence? c) #f]
|
||||
[else
|
||||
(define prj (contract-late-neg-projection c))
|
||||
(prj (blame-add-field-context blame f #:swap? #f))]))
|
||||
(for/list ([f (in-list fields)]
|
||||
[c (in-list field-contracts)])
|
||||
(cond
|
||||
[(just-check-existence? c) #f]
|
||||
[else
|
||||
(define prj (contract-late-neg-projection c))
|
||||
(prj (blame-add-field-context blame f #:swap? #t))]))))
|
||||
|
||||
(define tc (and (not filled?) (make-thread-cell #f)))
|
||||
|
||||
(λ (cls neg-party)
|
||||
(let* ([name (class-name cls)]
|
||||
|
|
@ -1712,25 +1775,36 @@
|
|||
(when method-proj
|
||||
(define i (hash-ref method-ht m))
|
||||
(vector-set! meths i (make-method (method-proj (vector-ref meths i) neg-party) m))))))
|
||||
|
||||
|
||||
;; Handle external field contracts
|
||||
(unless (null? fields)
|
||||
(for ([f (in-list fields)]
|
||||
[c (in-list field-contracts)]
|
||||
[pos/neg-field-proj (in-list pos/neg-field-projs)])
|
||||
(unless (just-check-existence? c)
|
||||
(define fi (hash-ref field-ht f))
|
||||
(define p-pos (vector-ref pos/neg-field-proj 0))
|
||||
(define p-neg (vector-ref pos/neg-field-proj 1))
|
||||
(hash-set! field-ht f (field-info-extend-external fi
|
||||
(lambda args
|
||||
(with-contract-continuation-mark
|
||||
(cons blame neg-party)
|
||||
(apply p-pos args)))
|
||||
(lambda args
|
||||
(with-contract-continuation-mark
|
||||
(cons blame neg-party)
|
||||
(apply p-neg args)))
|
||||
neg-party)))))
|
||||
(define (install-new-fields pos-field-projs neg-field-projs)
|
||||
(for ([f (in-list fields)]
|
||||
[c (in-list field-contracts)]
|
||||
[p-pos (in-list pos-field-projs)]
|
||||
[p-neg (in-list neg-field-projs)])
|
||||
(unless (just-check-existence? c)
|
||||
(define fi (hash-ref field-ht f))
|
||||
(hash-set! field-ht f (field-info-extend-external
|
||||
fi
|
||||
(lambda args
|
||||
(with-contract-continuation-mark
|
||||
(cons blame neg-party)
|
||||
(apply p-pos args)))
|
||||
(lambda args
|
||||
(with-contract-continuation-mark
|
||||
(cons blame neg-party)
|
||||
(apply p-neg args)))
|
||||
neg-party)))))
|
||||
(cond
|
||||
[filled? (install-new-fields maybe-pos-field-projs maybe-neg-field-projs)]
|
||||
[(thread-cell-ref tc)
|
||||
=>
|
||||
(λ (pr) (install-new-fields (car pr) (cdr pr)))]
|
||||
[else
|
||||
(define pos-field-projs (maybe-pos-field-projs))
|
||||
(define neg-field-projs (maybe-neg-field-projs))
|
||||
(thread-cell-set! tc (cons pos-field-projs neg-field-projs))
|
||||
(install-new-fields pos-field-projs neg-field-projs)]))
|
||||
|
||||
(copy-seals cls c))))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user