diff --git a/racket/collects/racket/contract/base.rkt b/racket/collects/racket/contract/base.rkt index 857b341d67..d0d34b5ed1 100644 --- a/racket/collects/racket/contract/base.rkt +++ b/racket/collects/racket/contract/base.rkt @@ -43,7 +43,8 @@ "private/struct-dc.rkt" "private/struct-prop.rkt") (except-out (all-from-out "private/base.rkt") - current-contract-region) + current-contract-region + (for-syntax lifted-key add-lifted-property)) (except-out (all-from-out "private/misc.rkt") check-between/c check-unary-between/c diff --git a/racket/collects/racket/contract/private/base.rkt b/racket/collects/racket/contract/private/base.rkt index aee46da156..446bf538a6 100644 --- a/racket/collects/racket/contract/private/base.rkt +++ b/racket/collects/racket/contract/private/base.rkt @@ -3,7 +3,8 @@ (provide contract (rename-out [-recursive-contract recursive-contract]) current-contract-region - invariant-assertion) + invariant-assertion + (for-syntax lifted-key add-lifted-property)) (require (for-syntax racket/base syntax/name syntax/srcloc) racket/stxparam @@ -17,6 +18,13 @@ "generate.rkt" ) +(begin-for-syntax + (define lifted-key (gensym 'contract:lifted)) + ;; syntax? -> syntax? + ;; tells clients that the expression is a lifted application + (define (add-lifted-property stx) + (syntax-property stx lifted-key #t))) + (define-for-syntax lifted-ccrs (make-hasheq)) (define-syntax-parameter current-contract-region @@ -26,7 +34,8 @@ [id (hash-ref lifted-ccrs ctxt #f)]) (with-syntax ([id (or id (let ([id (syntax-local-lift-expression - (syntax/loc stx (quote-module-name)))]) + (add-lifted-property + (syntax/loc stx (quote-module-name))))]) (hash-set! lifted-ccrs ctxt (syntax-local-introduce id)) id))]) #'id)) diff --git a/racket/collects/racket/contract/private/opt.rkt b/racket/collects/racket/contract/private/opt.rkt index 2201eb1624..4743434a71 100644 --- a/racket/collects/racket/contract/private/opt.rkt +++ b/racket/collects/racket/contract/private/opt.rkt @@ -3,6 +3,7 @@ "misc.rkt" "blame.rkt" "guts.rkt" + "base.rkt" racket/stxparam) (require (for-syntax racket/base "helpers.rkt" @@ -273,7 +274,7 @@ (define-syntax (begin-lifted stx) (syntax-case stx () [(_ expr) - (syntax-local-lift-expression #'expr)])) + (syntax-local-lift-expression (add-lifted-property #'expr))])) (define-syntax (define-opt/c stx) (syntax-case stx () diff --git a/racket/collects/racket/contract/private/provide.rkt b/racket/collects/racket/contract/private/provide.rkt index d874ae1acd..9fd3edbe08 100644 --- a/racket/collects/racket/contract/private/provide.rkt +++ b/racket/collects/racket/contract/private/provide.rkt @@ -66,7 +66,6 @@ ;; keys for syntax property used below (define rename-id-key (gensym 'contract:rename-id)) - (define lifted-key (gensym 'contract:lifted)) (define neg-party-key (gensym 'contract:neg-party)) ;; identifier? identifier? -> identifier? @@ -74,11 +73,6 @@ (define (add-rename-id rename-id partial-id) (syntax-property partial-id rename-id-key rename-id)) - ;; syntax? -> syntax? - ;; tells clients that the expression is a lifted application - (define (add-lifted-property stx) - (syntax-property stx lifted-key #t)) - ;; identifier? -> identifier? ;; tells clients that the application of this id has an extra inserted argument (define (add-neg-party stx) @@ -119,7 +113,8 @@ ;; No: lift the neg name creation (syntax-local-introduce (syntax-local-lift-expression - #'(quote-module-name))))]) + (add-lifted-property + #'(quote-module-name)))))]) (when key (hash-set! global-saved-id-table key lifted-neg-party)) ;; Expand to a use of the lifted expression: (define (adjust-location new-stx)