diff --git a/collects/racket/contract/private/misc.rkt b/collects/racket/contract/private/misc.rkt index a78006f610..77d7889af3 100644 --- a/collects/racket/contract/private/misc.rkt +++ b/collects/racket/contract/private/misc.rkt @@ -2,6 +2,7 @@ (require (for-syntax racket/base) racket/promise + (only-in "../../private/promise.rkt" prop:force promise-forcer) "prop.rkt" "blame.rkt" "guts.rkt" @@ -825,7 +826,8 @@ (λ (ctc-in) (let* ([ctc (coerce-contract 'promise/c ctc-in)] [ctc-proc (contract-projection ctc)]) - (make-contract + (define chap? (chaperone-contract? ctc)) + ((if chap? make-chaperone-contract make-contract) #:name (build-compound-type-name 'promise/c ctc) #:projection (λ (blame) @@ -837,7 +839,15 @@ val '(expected "," given: "~e") val)) - (delay (p-app (force val)))))) + (if chap? + (chaperone-struct + val + promise-forcer (λ (_ proc) + (chaperone-procedure + proc + (λ (promise) + (values p-app promise))))) + (delay (p-app (force val))))))) #:first-order promise?)))) (define/subexpression-pos-prop (parameter/c x) diff --git a/collects/racket/private/promise.rkt b/collects/racket/private/promise.rkt index 3b78e131b6..19db951b2a 100644 --- a/collects/racket/private/promise.rkt +++ b/collects/racket/private/promise.rkt @@ -8,6 +8,7 @@ (#%provide force promise? promise-forced? promise-running? ;; provided to create extensions (struct promise ()) pref pset! prop:force reify-result + promise-forcer promise-printer (struct running ()) (struct reraise ()) (for-syntax make-delayer)) diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 9968965dfd..1cf26f0bc5 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -9246,6 +9246,15 @@ x) 1) + (test/spec-passed/result + 'promise/c5 + '(let ([a (delay 7)]) + (equal? a + (contract (promise/c integer?) + a + 'pos + 'neg))) + #t) ; @@ -11355,6 +11364,9 @@ so that propagation occurs. (ctest #t flat-contract? (list/c integer?)) (ctest #t chaperone-contract? (list/c (-> integer? integer?))) + (ctest #t chaperone-contract? (promise/c integer?)) + (ctest #f chaperone-contract? (promise/c (new-∃/c 'alpha))) + ;; Make sure that impersonators cannot be used as the element contract in set/c. (contract-error-test 'contract-error-test-set