Add call/cc contracts to prompt-tag/c

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)))
+         (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))

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

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