port vector/c to late-neg projection (and throw away some redundant code)
This commit is contained in:
Robby Findler
parent
efcbd12116
commit
00c0ddb7f6
|
|
@ -134,20 +134,7 @@
|
|||
(for ([x (in-vector val)])
|
||||
(vfp+blame x neg-party))
|
||||
val)))
|
||||
#:stronger vectorof-stronger
|
||||
#:projection
|
||||
(λ (ctc)
|
||||
(define check (check-vectorof ctc))
|
||||
(λ (blame)
|
||||
(define raise-blame (λ (val . args) (apply raise-blame-error blame val args)))
|
||||
(define ele-blame (blame-add-element-of-context blame))
|
||||
(λ (val)
|
||||
(check val raise-blame #f)
|
||||
(let* ([elem-ctc (base-vectorof-elem ctc)]
|
||||
[p ((contract-projection elem-ctc) ele-blame)])
|
||||
(for ([e (in-vector val)])
|
||||
(p e)))
|
||||
val)))))
|
||||
#:stronger vectorof-stronger))
|
||||
|
||||
(define (blame-add-element-of-context blame #:swap? [swap? #f])
|
||||
(blame-add-context blame "an element of" #:swap? swap?))
|
||||
|
|
@ -210,37 +197,6 @@
|
|||
(define-values (prop:neg-blame-party prop:neg-blame-party? prop:neg-blame-party-get)
|
||||
(make-impersonator-property 'prop:neg-blame-party))
|
||||
|
||||
(define (vectorof-ho-projection vector-wrapper)
|
||||
(λ (ctc)
|
||||
(let ([elem-ctc (base-vectorof-elem ctc)]
|
||||
[immutable (base-vectorof-immutable ctc)]
|
||||
[check (check-vectorof ctc)])
|
||||
(λ (blame)
|
||||
(let ([elem-pos-proj ((contract-projection elem-ctc)
|
||||
(blame-add-element-of-context blame))]
|
||||
[elem-neg-proj ((contract-projection elem-ctc)
|
||||
(blame-add-element-of-context blame #:swap? #t))])
|
||||
(define checked-ref (λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame (elem-pos-proj val))))
|
||||
(define checked-set (λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame (elem-neg-proj val))))
|
||||
(define raise-blame (λ (val . args)
|
||||
(apply raise-blame-error blame val args)))
|
||||
(λ (val)
|
||||
(check val raise-blame #f)
|
||||
(if (and (immutable? val) (not (chaperone? val)))
|
||||
(apply vector-immutable
|
||||
(for/list ([e (in-vector val)])
|
||||
(elem-pos-proj e)))
|
||||
(vector-wrapper
|
||||
val
|
||||
checked-ref
|
||||
checked-set
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame blame))))))))
|
||||
|
||||
(define-struct (chaperone-vectorof base-vectorof) ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
#:property prop:chaperone-contract
|
||||
|
|
@ -248,8 +204,7 @@
|
|||
#:name vectorof-name
|
||||
#:first-order vectorof-first-order
|
||||
#:stronger vectorof-stronger
|
||||
#:late-neg-projection (vectorof-late-neg-ho-projection chaperone-vector)
|
||||
#:projection (vectorof-ho-projection chaperone-vector)))
|
||||
#:late-neg-projection (vectorof-late-neg-ho-projection chaperone-vector)))
|
||||
|
||||
(define-struct (impersonator-vectorof base-vectorof) ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
|
|
@ -258,8 +213,7 @@
|
|||
#:name vectorof-name
|
||||
#:first-order vectorof-first-order
|
||||
#:stronger vectorof-stronger
|
||||
#:late-neg-projection (vectorof-late-neg-ho-projection chaperone-vector)
|
||||
#:projection (vectorof-ho-projection impersonate-vector)))
|
||||
#:late-neg-projection (vectorof-late-neg-ho-projection chaperone-vector)))
|
||||
|
||||
(define-syntax (wrap-vectorof stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -312,26 +266,28 @@
|
|||
(list '#:immutable immutable)
|
||||
null)))))
|
||||
|
||||
(define (check-vector/c ctc val blame)
|
||||
(define (check-vector/c ctc val blame neg-party)
|
||||
(define elem-ctcs (base-vector/c-elems ctc))
|
||||
(define immutable (base-vector/c-immutable ctc))
|
||||
(unless (vector? val)
|
||||
(raise-blame-error blame val '(expected: "a vector" given: "~e") val))
|
||||
(raise-blame-error blame #:missing-party neg-party val
|
||||
'(expected: "a vector" given: "~e") val))
|
||||
(cond
|
||||
[(eq? immutable #t)
|
||||
(unless (immutable? val)
|
||||
(raise-blame-error blame val
|
||||
(raise-blame-error blame #:missing-party neg-party val
|
||||
'(expected: "an immutable vector" given: "~e")
|
||||
val))]
|
||||
[(eq? immutable #f)
|
||||
(when (immutable? val)
|
||||
(raise-blame-error blame val
|
||||
(raise-blame-error blame #:missing-party neg-party val
|
||||
'(expected: "a mutable vector" given: "~e")
|
||||
val))]
|
||||
[else (void)])
|
||||
(define elem-count (length elem-ctcs))
|
||||
(unless (= (vector-length val) elem-count)
|
||||
(raise-blame-error blame val '(expected: "a vector of ~a element~a" given: "~e")
|
||||
(raise-blame-error blame #:missing-party neg-party val
|
||||
'(expected: "a vector of ~a element~a" given: "~e")
|
||||
elem-count
|
||||
(if (= elem-count 1) "" "s")
|
||||
val)))
|
||||
|
|
@ -396,21 +352,24 @@
|
|||
#:name vector/c-name
|
||||
#:first-order vector/c-first-order
|
||||
#:stronger vector/c-stronger
|
||||
#:projection
|
||||
#:late-neg-projection
|
||||
(λ (ctc)
|
||||
(λ (blame)
|
||||
(define blame+ctxt (blame-add-element-of-context blame))
|
||||
(λ (val)
|
||||
(define val+np-acceptors
|
||||
(for/list ([c (in-list (base-vector/c-elems ctc))])
|
||||
((contract-late-neg-projection c) blame+ctxt)))
|
||||
(λ (val neg-party)
|
||||
(with-contract-continuation-mark
|
||||
blame
|
||||
(cons blame neg-party)
|
||||
(begin
|
||||
(check-vector/c ctc val blame)
|
||||
(check-vector/c ctc val blame neg-party)
|
||||
(for ([e (in-vector val)]
|
||||
[c (in-list (base-vector/c-elems ctc))])
|
||||
(((contract-projection c) blame+ctxt) e))
|
||||
[p (in-list val+np-acceptors)])
|
||||
(p e neg-party))
|
||||
val)))))))
|
||||
|
||||
(define (vector/c-ho-projection vector-wrapper)
|
||||
(define (vector/c-ho-late-neg-projection vector-wrapper)
|
||||
(λ (ctc)
|
||||
(let ([elem-ctcs (base-vector/c-elems ctc)]
|
||||
[immutable (base-vector/c-immutable ctc)])
|
||||
|
|
@ -418,29 +377,31 @@
|
|||
(let ([elem-pos-projs (for/vector #:length (length elem-ctcs)
|
||||
([c (in-list elem-ctcs)]
|
||||
[i (in-naturals)])
|
||||
((contract-projection c)
|
||||
((contract-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-projection c)
|
||||
((contract-late-neg-projection c)
|
||||
(blame-add-context blame (format "the ~a element of" (n->th i))
|
||||
#:swap? #t)))])
|
||||
(λ (val)
|
||||
(check-vector/c ctc val blame)
|
||||
(λ (val neg-party)
|
||||
(check-vector/c ctc val 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)))
|
||||
((vector-ref elem-pos-projs i) e neg-party)))
|
||||
(vector-wrapper
|
||||
val
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame ((vector-ref elem-pos-projs i) val)))
|
||||
(cons blame neg-party)
|
||||
((vector-ref elem-pos-projs i) val neg-party)))
|
||||
(λ (vec i val)
|
||||
(with-contract-continuation-mark
|
||||
blame ((vector-ref elem-neg-projs i) val)))
|
||||
(cons blame neg-party)
|
||||
((vector-ref elem-neg-projs i) val neg-party)))
|
||||
impersonator-prop:contracted ctc
|
||||
impersonator-prop:blame blame))))))))
|
||||
|
||||
|
|
@ -451,7 +412,7 @@
|
|||
#:name vector/c-name
|
||||
#:first-order vector/c-first-order
|
||||
#:stronger vector/c-stronger
|
||||
#:projection (vector/c-ho-projection chaperone-vector)))
|
||||
#:late-neg-projection (vector/c-ho-late-neg-projection chaperone-vector)))
|
||||
|
||||
(define-struct (impersonator-vector/c base-vector/c) ()
|
||||
#:property prop:custom-write custom-write-property-proc
|
||||
|
|
@ -460,7 +421,7 @@
|
|||
#:name vector/c-name
|
||||
#:first-order vector/c-first-order
|
||||
#:stronger vector/c-stronger
|
||||
#:projection (vector/c-ho-projection impersonate-vector)))
|
||||
#:late-neg-projection (vector/c-ho-late-neg-projection impersonate-vector)))
|
||||
|
||||
(define-syntax (wrap-vector/c stx)
|
||||
(syntax-case stx ()
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user