diff --git a/pkgs/racket-doc/scribblings/reference/contracts.scrbl b/pkgs/racket-doc/scribblings/reference/contracts.scrbl index 03cfe525e7..306851d18e 100644 --- a/pkgs/racket-doc/scribblings/reference/contracts.scrbl +++ b/pkgs/racket-doc/scribblings/reference/contracts.scrbl @@ -1784,8 +1784,11 @@ earlier fields.}} @defform/subs[ #:literals (struct rename) -(contract-out p/c-item ...) -([p/c-item +(contract-out unprotected-submodule contract-out-item ...) +([unprotected-submodule + (code:line) + (code:line #:unprotected-submodule submodule-name)] + [contract-out-item (struct id/super ((id contract-expr) ...) struct-option) (rename orig-id id contract-expr) @@ -1859,6 +1862,8 @@ Specifically, the symbol @indexed-racket['provide/contract-original-contract] is bound to vectors of two elements, the exported identifier and a syntax object for the expression that produces the contract controlling the export. + +@history[#:changed "7.3.0.3" @list{Added @racket[#:unprotected-submodule].}] } @defform[(recontract-out id ...)]{ @@ -1895,9 +1900,9 @@ the export. the private module. } -@defform[(provide/contract p/c-item ...)]{ +@defform[(provide/contract unprotected-submodule contract-out-item ...)]{ -A legacy shorthand for @racket[(provide (contract-out p/c-item ...))], +A legacy shorthand for @racket[(provide (contract-out unprotected-submodule contract-out-item ...))], except that a @racket[_contract-expr] within @racket[provide/contract] is evaluated at the position of the @racket[provide/contract] form instead of at the end of the enclosing module.} diff --git a/pkgs/racket-test/tests/racket/contract/contract-out.rkt b/pkgs/racket-test/tests/racket/contract/contract-out.rkt index 7256b2037a..cc4b2bf37d 100644 --- a/pkgs/racket-test/tests/racket/contract/contract-out.rkt +++ b/pkgs/racket-test/tests/racket/contract/contract-out.rkt @@ -1242,6 +1242,42 @@ (require 'provide/contract67-a racket/contract/base) (provide (contract-out (struct stream ([x any/c] [y any/c])))))))) + (test/spec-passed/result + 'provide/contract68 + '(let () + (eval '(module provide/contract68-a racket/base + (require racket/contract/base) + (provide (contract-out + #:unprotected-submodule unsafe + [f (-> integer? (listof integer?))])) + (define (f x) (list x)))) + + (eval '(module provide/contract68-b racket/base + (require (submod 'provide/contract68-a unsafe)) + (define answer (f #f)) + (provide answer))) + + (eval '(dynamic-require ''provide/contract68-b 'answer))) + '(#f)) + + (test/spec-passed/result + 'provide/contract69 + '(let () + (eval '(module provide/contract69-a racket/base + (require racket/contract/base) + (provide (contract-out + #:unprotected-submodule no-contract + (struct s ([x integer?])))) + (struct s (x)))) + + (eval '(module provide/contract69-b racket/base + (require (submod 'provide/contract69-a no-contract)) + (define answer (s-x (s #f))) + (provide answer))) + + (eval '(dynamic-require ''provide/contract69-b 'answer))) + '#f) + (contract-error-test 'provide/contract-struct-out #'(begin diff --git a/racket/collects/racket/contract/private/provide.rkt b/racket/collects/racket/contract/private/provide.rkt index d8c4cdcc6f..e1ab4c54cd 100644 --- a/racket/collects/racket/contract/private/provide.rkt +++ b/racket/collects/racket/contract/private/provide.rkt @@ -223,6 +223,8 @@ pai enpfn val))) +(define-for-syntax current-unprotected-submodule-name (make-parameter #f)) + ;; tl-code-for-one-id/new-name : syntax syntax syntax (union syntax #f) -> (values syntax syntax) ;; given the syntax for an identifier and a contract, ;; builds a begin expression for the entire contract and provide @@ -261,6 +263,11 @@ 'provide/contract pos-module-source #f) + #,@(let ([upe (current-unprotected-submodule-name)]) + (if upe + (list #`(module+ #,upe + (provide (rename-out [#,id external-name])))) + (list))) #,@(if provide? (list #`(provide (rename-out [#,id-rename external-name]))) null))) @@ -1108,7 +1115,19 @@ mangle-for-maker? provide?)) - (define p/c-clauses (syntax->list (syntax (p/c-ele ...)))) + (define-values (p/c-clauses unprotected-submodule-name) + (syntax-case (syntax (p/c-ele ...)) () + [(#:unprotected-submodule modname . more) + (identifier? #'modname) + (values (syntax->list #'more) (syntax-e #'modname))] + [(#:unprotected-submodule x . more) + (raise-syntax-error who + "expected a module name to follow #:unprotected-submodule" + provide-stx + (if (pair? (syntax-e #'more)) + (car (syntax-e #'more)) + #f))] + [_ (values (syntax->list (syntax (p/c-ele ...))) #f)])) (define struct-id-mapping (make-free-identifier-mapping)) (define (add-struct-clause-to-struct-id-mapping a parent flds/stx) (define flds (syntax->list flds/stx)) @@ -1141,26 +1160,26 @@ struct-id-mapping selector-id (id-for-one-id #f #f selector-id)))))) - - (cond - [just-check-errors? - (code-for-each-clause p/c-clauses) - (signal-dup-syntax-error)] - [else - (for ([clause (in-list p/c-clauses)]) - (syntax-case* clause (struct) (λ (x y) (eq? (syntax-e x) (syntax-e y))) - [(struct a ((fld ctc) ...) options ...) - (identifier? #'a) - (add-struct-clause-to-struct-id-mapping #'a #f #'(fld ...))] - [(struct (a b) ((fld ctc) ...) options ...) - (add-struct-clause-to-struct-id-mapping #'a #'b #'(fld ...))] - [_ (void)])) - (with-syntax ([(bodies ...) (code-for-each-clause p/c-clauses)] - [pos-module-source-id pos-module-source-id]) - (syntax - (begin - (define pos-module-source-id (quote-module-name)) - bodies ...)))]))])) + (parameterize ([current-unprotected-submodule-name unprotected-submodule-name]) + (cond + [just-check-errors? + (code-for-each-clause p/c-clauses) + (signal-dup-syntax-error)] + [else + (for ([clause (in-list p/c-clauses)]) + (syntax-case* clause (struct) (λ (x y) (eq? (syntax-e x) (syntax-e y))) + [(struct a ((fld ctc) ...) options ...) + (identifier? #'a) + (add-struct-clause-to-struct-id-mapping #'a #f #'(fld ...))] + [(struct (a b) ((fld ctc) ...) options ...) + (add-struct-clause-to-struct-id-mapping #'a #'b #'(fld ...))] + [_ (void)])) + (with-syntax ([(bodies ...) (code-for-each-clause p/c-clauses)] + [pos-module-source-id pos-module-source-id]) + (syntax + (begin + (define pos-module-source-id (quote-module-name)) + bodies ...)))])))])) (define-for-syntax (provide/contract-for-whom stx who)