diff --git a/collects/racket/contract/private/misc.rkt b/collects/racket/contract/private/misc.rkt index 294fe59a35..64c3d93692 100644 --- a/collects/racket/contract/private/misc.rkt +++ b/collects/racket/contract/private/misc.rkt @@ -957,34 +957,56 @@ (define/final-prop none/c (make-none/c 'none/c)) ;; prompt-tag/c -(define/subexpression-pos-prop (prompt-tag/c . ctc-args) - (define ctcs - (map (λ (ctc-arg) - (coerce-contract 'prompt-tag/c ctc-arg)) - ctc-args)) - (cond [(andmap chaperone-contract? ctcs) - (chaperone-prompt-tag/c ctcs)] +(define-syntax prompt-tag/c + (syntax-rules (values) + [(_ ?ctc ... #:call/cc (values ?call/cc ...)) + (-prompt-tag/c (list ?ctc ...) (list ?call/cc ...))] + [(_ ?ctc ... #:call/cc ?call/cc) + (-prompt-tag/c (list ?ctc ...) (list ?call/cc))] + [(_ ?ctc ...) (-prompt-tag/c (list ?ctc ...) (list))])) + +;; procedural part of the contract +;; takes two lists of contracts (abort & call/cc contracts) +(define/subexpression-pos-prop (-prompt-tag/c ctc-args call/ccs) + (define ctcs (coerce-contracts 'prompt-tag/c ctc-args)) + (define call/cc-ctcs (coerce-contracts 'prompt-tag/c call/ccs)) + (cond [(and (andmap chaperone-contract? ctcs) + (andmap chaperone-contract? call/cc-ctcs)) + (chaperone-prompt-tag/c ctcs call/cc-ctcs)] [else - (impersonator-prompt-tag/c ctcs)])) + (impersonator-prompt-tag/c ctcs call/cc-ctcs)])) (define (prompt-tag/c-name ctc) (apply build-compound-type-name - (cons 'prompt-tag/c (base-prompt-tag/c-ctcs ctc)))) + (append (list 'prompt-tag/c) (base-prompt-tag/c-ctcs ctc) + (list '#:call/cc) (base-prompt-tag/c-call/ccs ctc)))) -(define ((prompt-tag/c-proj proxy) ctc) +;; build a projection for prompt tags +(define ((prompt-tag/c-proj chaperone?) ctc) + (define proxy (if chaperone? chaperone-prompt-tag impersonate-prompt-tag)) + (define proc-proxy (if chaperone? chaperone-procedure impersonate-procedure)) (define ho-projs (map contract-projection (base-prompt-tag/c-ctcs ctc))) + (define call/cc-projs + (map contract-projection (base-prompt-tag/c-call/ccs ctc))) (λ (blame) - (define proj1 + (define (make-proj projs swap?) (λ vs - (define vs2 (for/list ([proj ho-projs] [v vs]) - ((proj blame) v))) - (apply values vs2))) - (define proj2 - (λ vs - (define vs2 (for/list ([proj ho-projs] [v vs]) - ((proj (blame-swap blame)) v))) - (apply values vs2))) + (define vs2 (for/list ([proj projs] [v vs]) + ((proj (if swap? (blame-swap blame) blame)) v))) + (apply values vs2))) + ;; prompt/abort projections + (define proj1 (make-proj ho-projs #f)) + (define proj2 (make-proj ho-projs #t)) + ;; call/cc projections + (define call/cc-guard (make-proj call/cc-projs #f)) + (define call/cc-proxy + (λ (f) + (proc-proxy + f + (λ args + (apply values (make-proj call/cc-projs #t) args))))) + ;; now do the actual wrapping (λ (val) (unless (contract-first-order-passes? ctc val) (raise-blame-error @@ -992,7 +1014,7 @@ '(expected: "~s" given: "~e") (contract-name ctc) val)) - (proxy val proj1 proj2)))) + (proxy val proj1 proj2 call/cc-guard call/cc-proxy)))) (define ((prompt-tag/c-first-order ctc) v) (continuation-prompt-tag? v)) @@ -1001,14 +1023,18 @@ (and (base-prompt-tag/c? that) (andmap (λ (this that) (contract-stronger? this that)) (base-prompt-tag/c-ctcs this) - (base-prompt-tag/c-ctcs that)))) + (base-prompt-tag/c-ctcs that)) + (andmap (λ (this that) (contract-stronger? this that)) + (base-prompt-tag/c-call/ccs this) + (base-prompt-tag/c-call/ccs that)))) -(define-struct base-prompt-tag/c (ctcs)) +;; (listof contract) (listof contract) +(define-struct base-prompt-tag/c (ctcs call/ccs)) (define-struct (chaperone-prompt-tag/c base-prompt-tag/c) () #:property prop:chaperone-contract (build-chaperone-contract-property - #:projection (prompt-tag/c-proj chaperone-prompt-tag) + #:projection (prompt-tag/c-proj #t) #:first-order prompt-tag/c-first-order #:stronger prompt-tag/c-stronger? #:name prompt-tag/c-name)) @@ -1016,7 +1042,7 @@ (define-struct (impersonator-prompt-tag/c base-prompt-tag/c) () #:property prop:contract (build-contract-property - #:projection (prompt-tag/c-proj impersonate-prompt-tag) + #:projection (prompt-tag/c-proj #f) #:first-order prompt-tag/c-first-order #:stronger prompt-tag/c-stronger? #:name prompt-tag/c-name)) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index 87fb37d644..fa453dc8df 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -520,7 +520,12 @@ to the input. The result will be a copy for immutable hash tables, and either a } -@defproc[(prompt-tag/c [contract contract?] ...) contract?]{ +@defform/subs[#:literals (values) + (prompt-tag/c contract ... maybe-call/cc) + ([maybe-call/cc (code:line) + (code:line #:call/cc contract) + (code:line #:call/cc (values contract ...))]) + #:contracts ([contract contract?])]{ Takes any number of contracts and returns a contract that recognizes continuation prompt tags and will check any aborts or prompt handlers that use the contracted prompt tag. @@ -533,6 +538,10 @@ If all of the @racket[contract]s are chaperone contracts, the resulting contract will also be a @tech{chaperone} contract. Otherwise, the contract is an @tech{impersonator} contract. +If @racket[maybe-call/cc] is provided, then the provided contracts +are used to check the return values from a continuation captured with +@racket[call-with-current-continuation]. + @examples[#:eval (contract-eval) (define/contract tag (prompt-tag/c (-> number? string?)) diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 77a2317ae8..dd93b870c4 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -4166,6 +4166,58 @@ pt (λ (x y) (values x y))))) + (test/spec-passed + 'prompt-tag/c-call/cc-1 + '(let* ([pt (contract (prompt-tag/c string? + #:call/cc string?) + (make-continuation-prompt-tag) + 'pos + 'neg)] + [abort-k (call-with-continuation-prompt + (λ () (call/cc (λ (k) k) pt)) + pt)]) + (call-with-continuation-prompt + (λ () (abort-k "ok")) + pt + (λ (s) (string-append s "post"))))) + + (test/spec-passed + 'prompt-tag/c-call/cc-2 + '(let* ([pt (contract (prompt-tag/c string? + #:call/cc (values string? integer?)) + (make-continuation-prompt-tag) + 'pos + 'neg)] + [abort-k (call-with-continuation-prompt + (λ () (call/cc (λ (k) k) pt)) + pt)]) + (call-with-continuation-prompt + (λ () (abort-k "ok" 5)) + pt + (λ (s n) (string-append s "post"))))) + + (test/neg-blame + 'prompt-tag/c-call/cc-2 + '(letrec ([pt (make-continuation-prompt-tag)] + [do-test (λ () + (+ 1 + (call-with-continuation-prompt + (lambda () + (+ 1 (abort-k 1))) + pt)))] + [cpt (contract (prompt-tag/c #:call/cc number?) + pt + 'pos + 'neg)] + [abort-k (call-with-continuation-prompt + (λ () + (let ([v (call/cc (lambda (k) k) cpt)]) + (if (procedure? v) + v + (format "~a" v)))) + pt)]) + (do-test))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; continuation-mark-key/c