From 00c0ddb7f697761e5b2548ebb642b48cdee94d18 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 19 Dec 2015 17:23:13 -0600 Subject: [PATCH] port vector/c to late-neg projection (and throw away some redundant code) --- .../racket/contract/private/vector.rkt | 101 ++++++------------ 1 file changed, 31 insertions(+), 70 deletions(-) diff --git a/racket/collects/racket/contract/private/vector.rkt b/racket/collects/racket/contract/private/vector.rkt index 264775c635..9274738fe1 100644 --- a/racket/collects/racket/contract/private/vector.rkt +++ b/racket/collects/racket/contract/private/vector.rkt @@ -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 ()