From 5f77da9f5d1383099ac4105c600fa98287a55d2b Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Sun, 30 Dec 2018 17:40:26 -0600 Subject: [PATCH] split out and provide make-apply-contract --- .../collects/racket/contract/private/base.rkt | 19 +++++++++++++------ 1 file changed, 13 insertions(+), 6 deletions(-) diff --git a/racket/collects/racket/contract/private/base.rkt b/racket/collects/racket/contract/private/base.rkt index 465cbaaa1a..968c26eaac 100644 --- a/racket/collects/racket/contract/private/base.rkt +++ b/racket/collects/racket/contract/private/base.rkt @@ -1,6 +1,7 @@ #lang racket/base (provide contract + make-apply-contract (rename-out [-recursive-contract recursive-contract]) current-contract-region invariant-assertion @@ -68,6 +69,9 @@ #f)))])) (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)]) (check-source-location! 'contract loc) (define clnp (contract-late-neg-projection c)) @@ -87,13 +91,16 @@ (if clnp #f neg) #t #: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 - [clnp (with-contract-continuation-mark - (cons blame neg) - ((clnp blame) v neg))] - [else (with-contract-continuation-mark - blame - (((contract-projection c) blame) v))]))) + [clnp + (define proj (with-ccm (clnp blame))) + (lambda (v) (with-ccm (proj v neg)))] + [else + (define proj (with-ccm ((contract-projection c) blame))) + (lambda (v) (with-ccm (proj v)))]))) (define-syntax (invariant-assertion stx) (syntax-case stx ()