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

More cons lifting.

Browse Source
This commit is contained in:
Vincent St-Amour 2016-01-27 14:25:47 -06:00
parent 870b8d4137
commit fe900e0d7a
4 changed files with 29 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
racket/collects/racket/contract/private/case-arrow.rkt
View File

@ -142,16 +142,17 @@
#,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...)))) #,@(apply append (map syntax->list (syntax->list #'((dom-proj-x ...) ...))))
#,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...))))) #,@(apply append (map syntax->list (syntax->list #'((rng-proj-x ...) ...)))))
(λ (f neg-party) (λ (f neg-party)
(define blame+neg-party (cons blame neg-party))
(put-it-together (put-it-together
#,(let ([case-lam (syntax/loc stx #,(let ([case-lam (syntax/loc stx
(case-lambda [formals body] ...))]) (case-lambda [formals body] ...))])
(if name (if name
#`(let ([#,name #,case-lam]) #,name) #`(let ([#,name #,case-lam]) #,name)
case-lam)) 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))))))))])) 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?) (chk f mtd?)
(define rng-ctcs (base-case->-rng-ctcs ctc)) (define rng-ctcs (base-case->-rng-ctcs ctc))
(define checker (define checker
@ -159,7 +160,7 @@
(raise-no-keywords-error f blame neg-party) (raise-no-keywords-error f blame neg-party)
(λ args (λ args
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(apply the-case-lam args))))) (apply the-case-lam args)))))
(define same-rngs (same-range-contracts rng-ctcs)) (define same-rngs (same-range-contracts rng-ctcs))
(if same-rngs (if same-rngs

6
racket/collects/racket/contract/private/misc.rkt
View File

@ -333,6 +333,7 @@
(λ (blame) (λ (blame)
(define p-app (ctc-proc (blame-add-context blame "the promise from"))) (define p-app (ctc-proc (blame-add-context blame "the promise from")))
(λ (val neg-party) (λ (val neg-party)
(define blame+neg-party (cons blame neg-party))
(if (promise? val) (if (promise? val)
(c/i-struct (c/i-struct
val val
@ -342,7 +343,7 @@
proc proc
(λ (promise) (λ (promise)
(values (λ (val) (with-contract-continuation-mark (values (λ (val) (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
(p-app val neg-party))) (p-app val neg-party)))
promise))))) promise)))))
(raise-blame-error (raise-blame-error
@ -406,12 +407,13 @@
(define in-proj (in-proc (blame-swap blame/c))) (define in-proj (in-proc (blame-swap blame/c)))
(define out-proj (out-proc blame/c)) (define out-proj (out-proc blame/c))
(λ (val neg-party) (λ (val neg-party)
(define blame+neg-party (cons blame/c neg-party))
(cond (cond
[(parameter? val) [(parameter? val)
(define (add-profiling f) (define (add-profiling f)
(λ (x) (λ (x)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame/c neg-party) blame+neg-party
(f x neg-party)))) (f x neg-party))))
(make-derived-parameter (make-derived-parameter
val val

27
racket/collects/racket/contract/private/parametric.rkt
View File

@ -60,9 +60,9 @@
(define negative? (blame-swapped? blame)) (define negative? (blame-swapped? blame))
(define barrier/c (polymorphic-contract-barrier c)) (define barrier/c (polymorphic-contract-barrier c))
(define vars (polymorphic-contract-vars c)) (define vars (polymorphic-contract-vars c))
(define (wrap p neg-party) (define (wrap p neg-party blame+neg-party)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
;; values in polymorphic types come in from negative position, ;; values in polymorphic types come in from negative position,
;; relative to the poly/c contract ;; relative to the poly/c contract
(define instances (define instances
@ -76,19 +76,20 @@
(unless (procedure? p) (unless (procedure? p)
(raise-blame-error blame #:missing-party neg-party (raise-blame-error blame #:missing-party neg-party
p '(expected "a procedure" given: "~e") p)) p '(expected "a procedure" given: "~e") p))
(define blame+neg-party (cons blame neg-party))
(make-keyword-procedure (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 (case-lambda
[() ((wrap p neg-party))] [() ((wrap p neg-party blame+neg-party))]
[(a) ((wrap p neg-party) a)] [(a) ((wrap p neg-party blame+neg-party) a)]
[(a b) ((wrap p neg-party) a b)] [(a b) ((wrap p neg-party blame+neg-party) a b)]
[(a b c) ((wrap p neg-party) a b c)] [(a b c) ((wrap p neg-party blame+neg-party) a b c)]
[(a b c d) ((wrap p neg-party) a b c d)] [(a b c d) ((wrap p neg-party blame+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) ((wrap p neg-party blame+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) ((wrap p neg-party blame+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) ((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) a b c d e f g h)] [(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) args)]))))))) [args (apply (wrap p neg-party blame+neg-party) args)])))))))
(define (opaque/c positive? name) (define (opaque/c positive? name)
(define-values [ type make pred getter setter ] (define-values [ type make pred getter setter ]

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

@ -156,14 +156,16 @@
(define elem-pos-proj (vfp pos-blame)) (define elem-pos-proj (vfp pos-blame))
(define elem-neg-proj (vfp neg-blame)) (define elem-neg-proj (vfp neg-blame))
(define checked-ref (λ (neg-party) (define checked-ref (λ (neg-party)
(define blame+neg-party (cons pos-blame neg-party))
(λ (vec i val) (λ (vec i val)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons pos-blame neg-party) blame+neg-party
(elem-pos-proj val neg-party))))) (elem-pos-proj val neg-party)))))
(define checked-set (λ (neg-party) (define checked-set (λ (neg-party)
(define blame+neg-party (cons neg-blame neg-party))
(λ (vec i val) (λ (vec i val)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons neg-blame neg-party) blame+neg-party
(elem-neg-proj val neg-party))))) (elem-neg-proj val neg-party)))))
(cond (cond
[(flat-contract? elem-ctc) [(flat-contract? elem-ctc)
@ -389,6 +391,7 @@
#:swap? #t)))]) #:swap? #t)))])
(λ (val neg-party) (λ (val neg-party)
(check-vector/c ctc val blame 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))) (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)]
@ -398,11 +401,11 @@
val val
(λ (vec i val) (λ (vec i val)
(with-contract-continuation-mark (with-contract-continuation-mark
(cons blame neg-party) blame+neg-party
((vector-ref elem-pos-projs i) val 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
(cons blame neg-party) blame+neg-party
((vector-ref elem-neg-projs i) val 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))))))))