diff --git a/collects/racket/private/reqprov.rkt b/collects/racket/private/reqprov.rkt index 180791c81c..dc1c9bf272 100644 --- a/collects/racket/private/reqprov.rkt +++ b/collects/racket/private/reqprov.rkt @@ -14,7 +14,8 @@ provide all-defined-out all-from-out rename-out except-out prefix-out struct-out combine-out - protect-out) + protect-out + local-require) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; helpers @@ -960,5 +961,61 @@ (export-orig-stx e))) exports))])))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + + ;; rename-import : Import Identifier -> Import + ;; Creates a new import that binds the given identifier, but otherwise acts as + ;; the original import. + (define-for-syntax (rename-import i id) + (make-import id + (import-src-sym i) + (import-src-mod-path i) + (import-mode i) + (import-req-mode i) + (import-orig-mode i) + (import-orig-stx i))) + + ;; import->raw-require-spec : Import -> Syntax + ;; Constructs a raw-require-spec (suitable for #%require) that should have the + ;; same behavior as a require-spec that produces the given import. + (define-for-syntax (import->raw-require-spec i) + (datum->syntax + (import-orig-stx i) + (list #'just-meta + (import-req-mode i) + (list #'for-meta + (import-mode i) + (list #'rename + (import-src-mod-path i) + (syntax-local-introduce (import-local-id i)) + (import-src-sym i)))) + (import-orig-stx i))) + + ;; (do-local-require rename spec ...) + ;; Lifts (require spec ...) to the (module) top level, and makes the imported + ;; bindings available in the current context via a renaming macro. + (define-syntax (local-require stx) + (when (eq? 'expression (syntax-local-context)) + (raise-syntax-error #f "not allowed in an expression context" stx)) + (syntax-case stx [] + [(_ spec ...) + (let*-values ([(imports sources) + (expand-import + (datum->syntax + stx + (list* #'only-meta-in 0 (syntax->list #'(spec ...))) + stx))] + [(names) (map import-local-id imports)] + [(reqd-names) + (let ([ctx (syntax-local-get-shadower (datum->syntax #f (gensym)))]) + (map (lambda (n) (datum->syntax ctx (syntax-e n) n)) names))] + [(renamed-imports) (map rename-import imports reqd-names)] + [(raw-specs) (map import->raw-require-spec renamed-imports)] + [(lifts) (map syntax-local-lift-require raw-specs reqd-names)]) + (with-syntax ([(name ...) names] + [(lifted ...) lifts]) + (syntax/loc stx (define-syntaxes (name ...) + (values (make-rename-transformer #'lifted) ...)))))])) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ) diff --git a/collects/scheme/base.rkt b/collects/scheme/base.rkt index 9838a94b0a..9a51eb9d95 100644 --- a/collects/scheme/base.rkt +++ b/collects/scheme/base.rkt @@ -4,6 +4,7 @@ (provide (except-out (all-from-out racket/base) struct hash hasheq hasheqv - in-directory) + in-directory + local-require) make-base-empty-namespace make-base-namespace) diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 1ce4e9d77f..5e5268ec68 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -652,6 +652,12 @@ original definition in the same module. In a @tech{module context}, an identifier can be either imported or defined for a given @tech{phase level}, but not both.} +@defform[(local-require require-spec ...)]{ + +Like @scheme[require], but for use in a local-definition context to +import just into the local context. Only bindings from @tech{phase +level} 0 are imported.} + @guideintro["module-provide"]{@racket[provide]} diff --git a/collects/scribblings/scheme/scheme.scrbl b/collects/scribblings/scheme/scheme.scrbl index 2d31d6137a..3c0b4c47a3 100644 --- a/collects/scribblings/scheme/scheme.scrbl +++ b/collects/scribblings/scheme/scheme.scrbl @@ -1,11 +1,11 @@ #lang scribble/manual -@(require (for-syntax racket) - (for-label (only-in scheme/foreign unsafe! provide* define-unsafer) +@(require (for-label (only-in scheme/foreign unsafe! provide* define-unsafer) (only-in scheme/base make-base-namespace make-base-empty-namespace) (only-in scheme/pretty pretty-print) (only-in racket/pretty pretty-write) (only-in scheme/class printable<%>) (only-in racket/class writable<%>) + (only-in racket/base struct hash hasheq hasheqv in-directory local-require) scheme/gui/base scheme/sandbox)) @@ -56,8 +56,8 @@ old name. A few @seclink["compat-exe"]{old executables} are also provided. @table-of-contents[] -@compat-except[scheme racket]{, except that @schememodname[racket]'s -@scheme[struct] is not exported, the @|unit-struct| from +@compat-except[scheme racket]{, except based on @schememodname[scheme/base] +instead of @schememodname[racket/base], the @|unit-struct| from @schememodname[scheme/unit] is exported, @schememodname[scheme/set] is not re-exported, @schememodname[scheme/system] is not re-exported, @racket[pretty-print] is re-directed in as @@ -65,8 +65,9 @@ not re-exported, @racket[pretty-print] is re-directed in as re-exported} @compat-except[scheme/base racket/base]{, except that -@schememodname[racket]'s @scheme[struct] is not exported, @scheme[in-directory] -is not exported, and +@schememodname[racket]'s @scheme[struct], @scheme[hash], +@scheme[hasheq], @scheme[hasheqv], @scheme[in-directory], and +@scheme[local-require] are not exported, and @scheme[make-base-namespace] and @scheme[make-base-empty-namespace] are different}