From fe900e0d7a18f9429277aa75a2a4b76c686f0da2 Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Wed, 27 Jan 2016 14:25:47 -0600 Subject: [PATCH] More cons lifting. --- .../racket/contract/private/case-arrow.rkt | 7 ++--- .../collects/racket/contract/private/misc.rkt | 6 +++-- .../racket/contract/private/parametric.rkt | 27 ++++++++++--------- .../racket/contract/private/vector.rkt | 11 +++++--- 4 files changed, 29 insertions(+), 22 deletions(-) diff --git a/racket/collects/racket/contract/private/case-arrow.rkt b/racket/collects/racket/contract/private/case-arrow.rkt index 5e43e69e28..fe6767ce0a 100644 --- a/racket/collects/racket/contract/private/case-arrow.rkt +++ b/racket/collects/racket/contract/private/case-arrow.rkt @@ -142,16 +142,17 @@ #,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...)))) #,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...))))) (λ (f neg-party) + (define blame+neg-party (cons blame neg-party)) (put-it-together #,(let ([case-lam (syntax/loc stx (case-lambda [formals body] ...))]) (if name #`(let ([#,name #,case-lam]) #,name) case-lam)) - f blame neg-party blame-party-info wrapper ctc + f blame neg-party blame+neg-party blame-party-info wrapper ctc chk #,(and (syntax-parameter-value #'making-a-method) #t))))))))])) -(define (put-it-together the-case-lam f blame neg-party blame-party-info wrapper ctc chk mtd?) +(define (put-it-together the-case-lam f blame neg-party blame+neg-party blame-party-info wrapper ctc chk mtd?) (chk f mtd?) (define rng-ctcs (base-case->-rng-ctcs ctc)) (define checker @@ -159,7 +160,7 @@ (raise-no-keywords-error f blame neg-party) (λ args (with-contract-continuation-mark - (cons blame neg-party) + blame+neg-party (apply the-case-lam args))))) (define same-rngs (same-range-contracts rng-ctcs)) (if same-rngs diff --git a/racket/collects/racket/contract/private/misc.rkt b/racket/collects/racket/contract/private/misc.rkt index cf186082e6..7c0ae6598d 100644 --- a/racket/collects/racket/contract/private/misc.rkt +++ b/racket/collects/racket/contract/private/misc.rkt @@ -333,6 +333,7 @@ (λ (blame) (define p-app (ctc-proc (blame-add-context blame "the promise from"))) (λ (val neg-party) + (define blame+neg-party (cons blame neg-party)) (if (promise? val) (c/i-struct val @@ -342,7 +343,7 @@ proc (λ (promise) (values (λ (val) (with-contract-continuation-mark - (cons blame neg-party) + blame+neg-party (p-app val neg-party))) promise))))) (raise-blame-error @@ -406,12 +407,13 @@ (define in-proj (in-proc (blame-swap blame/c))) (define out-proj (out-proc blame/c)) (λ (val neg-party) + (define blame+neg-party (cons blame/c neg-party)) (cond [(parameter? val) (define (add-profiling f) (λ (x) (with-contract-continuation-mark - (cons blame/c neg-party) + blame+neg-party (f x neg-party)))) (make-derived-parameter val diff --git a/racket/collects/racket/contract/private/parametric.rkt b/racket/collects/racket/contract/private/parametric.rkt index 1f6e3d4a52..211c397253 100644 --- a/racket/collects/racket/contract/private/parametric.rkt +++ b/racket/collects/racket/contract/private/parametric.rkt @@ -60,9 +60,9 @@ (define negative? (blame-swapped? blame)) (define barrier/c (polymorphic-contract-barrier c)) (define vars (polymorphic-contract-vars c)) - (define (wrap p neg-party) + (define (wrap p neg-party blame+neg-party) (with-contract-continuation-mark - (cons blame neg-party) + blame+neg-party ;; values in polymorphic types come in from negative position, ;; relative to the poly/c contract (define instances @@ -76,19 +76,20 @@ (unless (procedure? p) (raise-blame-error blame #:missing-party neg-party p '(expected "a procedure" given: "~e") p)) + (define blame+neg-party (cons blame neg-party)) (make-keyword-procedure - (lambda (keys vals . args) (keyword-apply (wrap p neg-party) keys vals args)) + (lambda (keys vals . args) (keyword-apply (wrap p neg-party blame+neg-party) keys vals args)) (case-lambda - [() ((wrap p neg-party))] - [(a) ((wrap p neg-party) a)] - [(a b) ((wrap p neg-party) a b)] - [(a b c) ((wrap p neg-party) a b c)] - [(a b c d) ((wrap p neg-party) a b c d)] - [(a b c d e) ((wrap p neg-party) a b c d e)] - [(a b c d e f) ((wrap p neg-party) a b c d e f)] - [(a b c d e f g) ((wrap p neg-party) a b c d e f g)] - [(a b c d e f g h) ((wrap p neg-party) a b c d e f g h)] - [args (apply (wrap p neg-party) args)]))))))) + [() ((wrap p neg-party blame+neg-party))] + [(a) ((wrap p neg-party blame+neg-party) a)] + [(a b) ((wrap p neg-party blame+neg-party) a b)] + [(a b c) ((wrap p neg-party blame+neg-party) a b c)] + [(a b c d) ((wrap p neg-party blame+neg-party) a b c d)] + [(a b c d e) ((wrap p neg-party blame+neg-party) a b c d e)] + [(a b c d e f) ((wrap p neg-party blame+neg-party) a b c d e f)] + [(a b c d e f g) ((wrap p neg-party blame+neg-party) a b c d e f g)] + [(a b c d e f g h) ((wrap p neg-party blame+neg-party) a b c d e f g h)] + [args (apply (wrap p neg-party blame+neg-party) args)]))))))) (define (opaque/c positive? name) (define-values [ type make pred getter setter ] diff --git a/racket/collects/racket/contract/private/vector.rkt b/racket/collects/racket/contract/private/vector.rkt index a547edf76d..f1dfb0c962 100644 --- a/racket/collects/racket/contract/private/vector.rkt +++ b/racket/collects/racket/contract/private/vector.rkt @@ -156,14 +156,16 @@ (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 - (cons pos-blame neg-party) + 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 - (cons neg-blame neg-party) + blame+neg-party (elem-neg-proj val neg-party))))) (cond [(flat-contract? elem-ctc) @@ -389,6 +391,7 @@ #: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)] @@ -398,11 +401,11 @@ val (λ (vec i val) (with-contract-continuation-mark - (cons blame neg-party) + blame+neg-party ((vector-ref elem-pos-projs i) val neg-party))) (λ (vec i val) (with-contract-continuation-mark - (cons blame neg-party) + blame+neg-party ((vector-ref elem-neg-projs i) val neg-party))) impersonator-prop:contracted ctc impersonator-prop:blame blame))))))))