dont use unsafe-{chaperone,impersonator}-procedure when {chaperone,impersonator}-procedure* might be involved

This commit is contained in:
Robby Findler 2016-01-25 23:51:38 -06:00
parent 39a1b81b6a
commit 6723c64487
2 changed files with 25 additions and 0 deletions
pkgs/racket-test/tests/racket/contract
racket/collects/racket/contract/private

View File

@ -379,6 +379,27 @@
'something-else 'yet-another-thing) 'something-else 'yet-another-thing)
1))) 1)))
(test/spec-passed/result
'chaperone-procedure*-and-contract-interaction
'(let ()
(define (f1 x) x)
(define-values (prop:p prop:p? prop:get-p)
(make-impersonator-property 'p))
(define the-answer 'dont-know)
(define f2 (chaperone-procedure*
f1
(λ (f x)
(set! the-answer (and (prop:p? f) (prop:get-p f)))
x)))
(define f3 (contract (-> integer? integer?) f2 'pos 'neg))
(define f4 (chaperone-procedure f3 #f prop:p 1234))
(f4 1)
the-answer)
1234)
(test/pos-blame (test/pos-blame
'predicate/c1 'predicate/c1
'(contract predicate/c 1 'pos 'neg)) '(contract predicate/c 1 'pos 'neg))

View File

@ -460,6 +460,10 @@
[(matches-arity-exactly? val min-arity max-arity req-kwd opt-kwd) [(matches-arity-exactly? val min-arity max-arity req-kwd opt-kwd)
(if (and (null? req-kwd) (null? opt-kwd)) (if (and (null? req-kwd) (null? opt-kwd))
(cond (cond
[(impersonator? val)
(if basic-unsafe-lambda
(values basic-lambda #f)
basic-lambda)]
[(and basic-unsafe-lambda [(and basic-unsafe-lambda
basic-unsafe-lambda/result-values-assumed basic-unsafe-lambda/result-values-assumed
(equal? contract-result-val-count (equal? contract-result-val-count