Added continuation-mark/c

collects/racket/contract/private/misc.rkt

@@ -36,6 +36,7 @@
          make-none/c
 
          prompt/c
+         continuation-mark/c
 
          chaperone-contract?
          impersonator-contract?
@@ -1008,6 +1009,59 @@
    #:name prompt/c-name))
 
 
+;; continuation-mark/c
+(define/subexpression-pos-prop (continuation-mark/c ctc-arg)
+  (define ctc (coerce-contract 'continuation-mark/c ctc-arg))
+  (cond [(chaperone-contract? ctc) (chaperone-continuation-mark/c ctc)]
+        [else (impersonator-continuation-mark/c ctc)]))
+
+(define (continuation-mark/c-name ctc)
+  (build-compound-type-name
+   'continuation-mark/c
+   (base-continuation-mark/c-ctc ctc)))
+
+(define ((continuation-mark/c-proj proxy) ctc)
+  (define ho-proj (contract-projection (base-continuation-mark/c-ctc ctc)))
+  (λ (blame)
+    (define proj1 (λ (v) ((ho-proj blame) v)))
+    (define proj2 (λ (v) ((ho-proj (blame-swap blame)) v)))
+    (λ (val)
+      (unless (contract-first-order-passes? ctc val)
+        (raise-blame-error
+         blame val
+         '(expected: "~s," given: "~e")
+         (contract-name ctc)
+         val))
+      (proxy val proj1 proj2))))
+
+(define ((continuation-mark/c-first-order ctc) v)
+  (continuation-mark-key? v))
+
+(define (continuation-mark/c-stronger? this that)
+  (and (base-continuation-mark/c? that)
+       (contract-stronger?
+        (base-continuation-mark/c-ctc this)
+        (base-continuation-mark/c-ctc that))))
+
+(define-struct base-continuation-mark/c (ctc))
+
+(define-struct (chaperone-continuation-mark/c base-continuation-mark/c) ()
+  #:property prop:chaperone-contract
+  (build-chaperone-contract-property
+   #:projection (continuation-mark/c-proj chaperone-continuation-mark-key)
+   #:first-order continuation-mark/c-first-order
+   #:stronger continuation-mark/c-stronger?
+   #:name continuation-mark/c-name))
+
+(define-struct (impersonator-continuation-mark/c base-continuation-mark/c) ()
+  #:property prop:contract
+  (build-contract-property
+   #:projection (continuation-mark/c-proj impersonate-continuation-mark-key)
+   #:first-order continuation-mark/c-first-order
+   #:stronger continuation-mark/c-stronger?
+   #:name continuation-mark/c-name))
+
+
 (define (flat-contract-predicate x)
   (contract-struct-first-order
    (coerce-flat-contract 'flat-contract-predicate x)))

collects/tests/racket/contmark.rktl

@@ -993,8 +993,9 @@
   (wcm-test '(#(5)) (lambda () (do-test* cha-mark 5)))
   (wcm-test 5 (lambda () (do-test/first cha-mark 5)))
   (wcm-test 5 (lambda () (do-test/immediate cha-mark 5)))
-  (err/rt-test (do-test cha-mark "fail") exn:fail?)
+  (err/rt-test (do-test cha-mark #t) exn:fail?)
-  (err/rt-test (do-test bad-mark 5) exn:fail?))
+  (err/rt-test (do-test bad-mark 5) exn:fail?)
+  (err/rt-test (do-test bad-mark-2 5) exn:fail?))
 
 ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 

collects/tests/racket/contract-test.rktl

@@ -4166,6 +4166,139 @@
         pt
         (λ (x y) (values x y)))))
 
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+  ;;
+  ;;  prompt/c
+  ;;
+  ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+  (test/spec-passed
+   'continuation-mark/c-fo-1
+   '(contract (continuation-mark/c string?)
+              (make-continuation-mark-key)
+              'pos 'neg))
+
+  (test/pos-blame
+   'continuation-mark/c-fo-2
+   '(contract (continuation-mark/c string?) 5 'pos 'neg))
+
+  ;; TODO: Does not pass due to compiler optimization
+  ;(test/neg-blame
+  ; 'continuation-mark/c-ho-1
+  ; '(let ([mark (contract (continuation-mark/c number?)
+  ;                        (make-continuation-mark-key)
+  ;                        'pos
+  ;                        'neg)])
+  ;    (with-continuation-mark mark "bad"
+  ;      42)))
+
+  (test/spec-passed
+   'continuation-mark/c-ho-2
+   '(let ([mark (contract (continuation-mark/c number?)
+                          (make-continuation-mark-key)
+                          'pos
+                          'neg)])
+      (with-continuation-mark mark 5
+        (continuation-mark-set-first
+         (current-continuation-marks) mark))))
+
+  (test/neg-blame
+   'continuation-mark/c-ho-3
+   '(let ([mark (contract (continuation-mark/c number?)
+                          (make-continuation-mark-key)
+                          'pos
+                          'neg)])
+      (with-continuation-mark mark "bad"
+        (continuation-mark-set-first
+         (current-continuation-marks) mark))))
+
+  (test/neg-blame
+   'continuation-mark/c-ho-4
+   '(let* ([mark (make-continuation-mark-key)]
+           [do-mark (contract (-> (-> (continuation-mark/c (-> number? number?))
+                                      number?)
+                                  number?)
+                              (lambda (f)
+                                (with-continuation-mark mark (lambda (x) (+ x 1))
+                                  (f mark)))
+                              'pos
+                              'neg)])
+      (do-mark
+       (lambda (mark)
+         ((continuation-mark-set-first
+           (current-continuation-marks) mark)
+          "bad")))))
+
+  (test/pos-blame
+   'continuation-mark/c-ho-5
+   '(let* ([mark (make-continuation-mark-key)]
+           [do-mark (contract (-> (-> (continuation-mark/c (-> number? number?))
+                                      number?)
+                                  number?)
+                              (lambda (f)
+                                (with-continuation-mark mark (lambda (x) "bad")
+                                  (f mark)))
+                              'pos
+                              'neg)])
+      (do-mark
+       (lambda (mark)
+         ((continuation-mark-set-first
+           (current-continuation-marks) mark)
+          0)))))
+
+  (test/spec-passed
+   'continuation-mark/c-ho-6
+   '(let* ([mark (make-continuation-mark-key)]
+           [do-mark (contract (-> (-> (continuation-mark/c (-> number? number?))
+                                      number?)
+                                  number?)
+                              (lambda (f)
+                                (with-continuation-mark mark (lambda (x) (+ x 1))
+                                  (f mark)))
+                              'pos
+                              'neg)])
+      (do-mark
+       (lambda (mark)
+         ((continuation-mark-set-first
+           (current-continuation-marks) mark)
+          0)))))
+
+  (test/neg-blame
+   'continuation-mark/c-ho-7
+   '(let ([mark (contract (continuation-mark/c (-> number? number?))
+                          (make-continuation-mark-key)
+                          'pos
+                          'neg)])
+      (with-continuation-mark mark (lambda (x) "bad")
+        ((continuation-mark-set-first
+          (current-continuation-marks) mark)
+         5))))
+
+  (test/spec-passed
+   'continuation-mark/c-ho-8
+   '(let ([mark (contract (continuation-mark/c (-> number? number?))
+                          (make-continuation-mark-key)
+                          'pos
+                          'neg)])
+      (with-continuation-mark mark (lambda (x) (+ x 1))
+        ((continuation-mark-set-first
+          (current-continuation-marks) mark)
+         0))))
+
+  (test/pos-blame
+   'continuation-mark/c-ho-9
+   '(let* ([mark (make-continuation-mark-key)]
+           [do-mark (contract (-> (continuation-mark/c (-> number? number?))
+                                  number?)
+                              (lambda (mark)
+                                ((continuation-mark-set-first
+                                  (current-continuation-marks) mark)
+                                 "bad"))
+                              'pos
+                              'neg)])
+      (with-continuation-mark mark (lambda (x) (+ x 1))
+        (do-mark mark))))
+
   ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
   ;;
   ;;  make-contract