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

port vector/c to late-neg projection (and throw away some redundant code)

Browse Source
This commit is contained in:
Robby Findler 2015-12-19 17:23:13 -06:00
parent efcbd12116
commit 00c0ddb7f6
1 changed files with 31 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -134,20 +134,7 @@
(for ([x (in-vector val)]) (for ([x (in-vector val)])
(vfp+blame x neg-party)) (vfp+blame x neg-party))
val))) val)))
#:stronger vectorof-stronger #: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)))))
(define (blame-add-element-of-context blame #:swap? [swap? #f]) (define (blame-add-element-of-context blame #:swap? [swap? #f])
(blame-add-context blame "an element of" #:swap? swap?)) (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) (define-values (prop:neg-blame-party prop:neg-blame-party? prop:neg-blame-party-get)
(make-impersonator-property 'prop:neg-blame-party)) (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) () (define-struct (chaperone-vectorof base-vectorof) ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
#:property prop:chaperone-contract #:property prop:chaperone-contract
@ -248,8 +204,7 @@
#:name vectorof-name #:name vectorof-name
#:first-order vectorof-first-order #:first-order vectorof-first-order
#:stronger vectorof-stronger #:stronger vectorof-stronger
#:late-neg-projection (vectorof-late-neg-ho-projection chaperone-vector) #:late-neg-projection (vectorof-late-neg-ho-projection chaperone-vector)))
#:projection (vectorof-ho-projection chaperone-vector)))
(define-struct (impersonator-vectorof base-vectorof) () (define-struct (impersonator-vectorof base-vectorof) ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
@ -258,8 +213,7 @@
#:name vectorof-name #:name vectorof-name
#:first-order vectorof-first-order #:first-order vectorof-first-order
#:stronger vectorof-stronger #:stronger vectorof-stronger
#:late-neg-projection (vectorof-late-neg-ho-projection chaperone-vector) #:late-neg-projection (vectorof-late-neg-ho-projection chaperone-vector)))
#:projection (vectorof-ho-projection impersonate-vector)))
(define-syntax (wrap-vectorof stx) (define-syntax (wrap-vectorof stx)
(syntax-case stx () (syntax-case stx ()
@ -312,26 +266,28 @@
(list '#:immutable immutable) (list '#:immutable immutable)
null))))) 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 elem-ctcs (base-vector/c-elems ctc))
(define immutable (base-vector/c-immutable ctc)) (define immutable (base-vector/c-immutable ctc))
(unless (vector? val) (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 (cond
[(eq? immutable #t) [(eq? immutable #t)
(unless (immutable? val) (unless (immutable? val)
(raise-blame-error blame val (raise-blame-error blame #:missing-party neg-party val
'(expected: "an immutable vector" given: "~e") '(expected: "an immutable vector" given: "~e")
val))] val))]
[(eq? immutable #f) [(eq? immutable #f)
(when (immutable? val) (when (immutable? val)
(raise-blame-error blame val (raise-blame-error blame #:missing-party neg-party val
'(expected: "a mutable vector" given: "~e") '(expected: "a mutable vector" given: "~e")
val))] val))]
[else (void)]) [else (void)])
(define elem-count (length elem-ctcs)) (define elem-count (length elem-ctcs))
(unless (= (vector-length val) elem-count) (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 elem-count
(if (= elem-count 1) "" "s") (if (= elem-count 1) "" "s")
val))) val)))
@ -396,21 +352,24 @@
#:name vector/c-name #:name vector/c-name
#:first-order vector/c-first-order #:first-order vector/c-first-order
#:stronger vector/c-stronger #:stronger vector/c-stronger
#:projection #:late-neg-projection
(λ (ctc) (λ (ctc)
(λ (blame) (λ (blame)
(define blame+ctxt (blame-add-element-of-context 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 (with-contract-continuation-mark
blame (cons blame neg-party)
(begin (begin
(check-vector/c ctc val blame) (check-vector/c ctc val blame neg-party)
(for ([e (in-vector val)] (for ([e (in-vector val)]
[c (in-list (base-vector/c-elems ctc))]) [p (in-list val+np-acceptors)])
(((contract-projection c) blame+ctxt) e)) (p e neg-party))
val))))))) val)))))))
(define (vector/c-ho-projection vector-wrapper) (define (vector/c-ho-late-neg-projection vector-wrapper)
(λ (ctc) (λ (ctc)
(let ([elem-ctcs (base-vector/c-elems ctc)] (let ([elem-ctcs (base-vector/c-elems ctc)]
[immutable (base-vector/c-immutable ctc)]) [immutable (base-vector/c-immutable ctc)])
@ -418,29 +377,31 @@
(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-projection c) ((contract-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-projection c) ((contract-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) (λ (val neg-party)
(check-vector/c ctc val blame) (check-vector/c ctc val blame neg-party)
(if (and (immutable? val) (not (chaperone? val))) (if (and (immutable? val) (not (chaperone? val)))
(apply vector-immutable (apply vector-immutable
(for/list ([e (in-vector val)] (for/list ([e (in-vector val)]
[i (in-naturals)]) [i (in-naturals)])
((vector-ref elem-pos-projs i) e))) ((vector-ref elem-pos-projs i) e neg-party)))
(vector-wrapper (vector-wrapper
val val
(λ (vec i val) (λ (vec i val)
(with-contract-continuation-mark (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) (λ (vec i val)
(with-contract-continuation-mark (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:contracted ctc
impersonator-prop:blame blame)))))))) impersonator-prop:blame blame))))))))
@ -451,7 +412,7 @@
#:name vector/c-name #:name vector/c-name
#:first-order vector/c-first-order #:first-order vector/c-first-order
#:stronger vector/c-stronger #: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) () (define-struct (impersonator-vector/c base-vector/c) ()
#:property prop:custom-write custom-write-property-proc #:property prop:custom-write custom-write-property-proc
@ -460,7 +421,7 @@
#:name vector/c-name #:name vector/c-name
#:first-order vector/c-first-order #:first-order vector/c-first-order
#:stronger vector/c-stronger #: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) (define-syntax (wrap-vector/c stx)
(syntax-case stx () (syntax-case stx ()