suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Added continuation-mark/c

Browse Source
This commit is contained in:
Asumu Takikawa 2012-06-13 12:49:32 -04:00
parent db6c37df92
commit de5c756d2e
3 changed files with 190 additions and 2 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
collects/racket/contract/private/misc.rkt
View File

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

5
collects/tests/racket/contmark.rktl
View File

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

133
collects/tests/racket/contract-test.rktl
View File

@ -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