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

split out and provide make-apply-contract

Browse Source
This commit is contained in:
Ryan Culpepper 2018-12-30 17:40:26 -06:00
parent ccfa41e22c
commit 5f77da9f5d
1 changed files with 13 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

19
racket/collects/racket/contract/private/base.rkt
View File

@ -1,6 +1,7 @@
#lang racket/base #lang racket/base
(provide contract (provide contract
make-apply-contract
(rename-out [-recursive-contract recursive-contract]) (rename-out [-recursive-contract recursive-contract])
current-contract-region current-contract-region
invariant-assertion invariant-assertion
@ -68,6 +69,9 @@
#f)))])) #f)))]))
(define (apply-contract c v pos neg name loc context-limit) (define (apply-contract c v pos neg name loc context-limit)
((make-apply-contract c pos neg name loc context-limit) v))
(define (make-apply-contract c pos neg name loc context-limit)
(let ([c (coerce-contract 'contract c)]) (let ([c (coerce-contract 'contract c)])
(check-source-location! 'contract loc) (check-source-location! 'contract loc)
(define clnp (contract-late-neg-projection c)) (define clnp (contract-late-neg-projection c))
@ -87,13 +91,16 @@
(if clnp #f neg) (if clnp #f neg)
#t #t
#:context-limit context-limit)) #:context-limit context-limit))
(define ccm-value (if clnp (cons blame neg) blame))
(define-syntax-rule (with-ccm e)
(with-contract-continuation-mark ccm-value e))
(cond (cond
[clnp (with-contract-continuation-mark [clnp
(cons blame neg) (define proj (with-ccm (clnp blame)))
((clnp blame) v neg))] (lambda (v) (with-ccm (proj v neg)))]
[else (with-contract-continuation-mark [else
blame (define proj (with-ccm ((contract-projection c) blame)))
(((contract-projection c) blame) v))]))) (lambda (v) (with-ccm (proj v)))])))
(define-syntax (invariant-assertion stx) (define-syntax (invariant-assertion stx)
(syntax-case stx () (syntax-case stx ()