From b211782bcde4433cdbced680a4ef1338e267c835 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Thu, 3 May 2012 16:13:33 -0400 Subject: [PATCH] Lift the use of (quote-module-name) by the default current-contract-region. --- collects/racket/contract/private/base.rkt | 13 ++++++++++++- 1 file changed, 12 insertions(+), 1 deletion(-) diff --git a/collects/racket/contract/private/base.rkt b/collects/racket/contract/private/base.rkt index d58a7e00ba..a3fe542536 100644 --- a/collects/racket/contract/private/base.rkt +++ b/collects/racket/contract/private/base.rkt @@ -14,8 +14,19 @@ "arrow.rkt" "misc.rkt") +(define-for-syntax lifted-ccrs (make-hasheq)) + (define-syntax-parameter current-contract-region - (λ (stx) #'(quote-module-name))) + (λ (stx) + (if (eq? (syntax-local-context) 'expression) + (let* ([ctxt (syntax-local-lift-context)] + [id (hash-ref lifted-ccrs ctxt #f)]) + (with-syntax ([id (or id + (let ([id (syntax-local-lift-expression (syntax/loc stx (quote-module-name)))]) + (hash-set! lifted-ccrs ctxt (syntax-local-introduce id)) + id))]) + #'id)) + (quasisyntax/loc stx (#%expression #,stx))))) (define-syntax (contract stx) (syntax-case stx ()