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 #'((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

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

@ -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

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

@ -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 ]

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

@ -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))))))))