diff --git a/collects/racket/contract/private/misc.rkt b/collects/racket/contract/private/misc.rkt index 7c33b0b141..af45e25852 100644 --- a/collects/racket/contract/private/misc.rkt +++ b/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))) diff --git a/collects/tests/racket/contmark.rktl b/collects/tests/racket/contmark.rktl index 924c62be0b..4a0d403411 100644 --- a/collects/tests/racket/contmark.rktl +++ b/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 bad-mark 5) 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-2 5) exn:fail?)) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 4887010d33..bd51f3c7c1 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/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