diff --git a/racket/collects/racket/lazy-require.rkt b/racket/collects/racket/lazy-require.rkt index 7b86cfd64d..89565ea7d5 100644 --- a/racket/collects/racket/lazy-require.rkt +++ b/racket/collects/racket/lazy-require.rkt @@ -3,16 +3,22 @@ compiler/cm-accomplice racket/runtime-path racket/promise) -(provide lazy-require) +(provide lazy-require + lazy-require-syntax) (define-syntax (lazy-require stx) (syntax-case stx () - [(lazy-require [modpath (thing ...)] ...) - #`(begin (lazy-require1 modpath (thing ...) #,stx) ...)])) - -(define-for-syntax counter 0) + [(lazy-require [modpath (import ...)] ...) + #`(begin (lazy-require1 modpath (import ...) #,stx) ...)])) (begin-for-syntax + + (define counter 0) + + (define (gen-aux-mod-name phase) + (begin0 (string->symbol (format "lazy-require-aux-~a-~a" phase counter)) + (set! counter (add1 counter)))) + ;; like (collapse-module-path modpath '(submod "..")), but avoids ;; the dependencies of syntax/modcollapse (define (module-path-add-submod-up modpath) @@ -33,40 +39,38 @@ modpath]))] [else ;; wasn't a submod module-path - modpath])))) + modpath]))) + + (define (process-imports ctx imports) + (for/list ([import (in-list imports)]) + (syntax-case import () + [name + (identifier? #'name) + (list #'name #'name)] + [[exp-name bind-name] + (begin + (unless (identifier? #'exp-name) + (raise-syntax-error #f "expected identifier" #'orig-stx #'exp-name)) + (unless (identifier? #'bind-name) + (raise-syntax-error #f "expected identifier" #'orig-stx #'bind-name)) + (list #'exp-name #'bind-name))] + [bad + (raise-syntax-error #f "expected identifier or pair of identifiers" + #'orig-stx #'bad)]))) + ) (define-syntax (lazy-require1 stx) (syntax-case stx () - [(lazy-require1 modpath (thing ...) orig-stx) + [(lazy-require1 modpath (import ...) orig-stx) (with-syntax ([((exp-name bind-name) ...) - (for/list ([thing-stx (in-list (syntax->list #'(thing ...)))]) - (syntax-case thing-stx () - [name - (identifier? #'name) - (list #'name #'name)] - [[exp-name bind-name] - (begin - (unless (identifier? #'exp-name) - (raise-syntax-error #f "expected identifier" - #'orig-stx #'exp-name)) - (unless (identifier? #'bind-name) - (raise-syntax-error #f "expected identifier" - #'orig-stx #'bind-name)) - (list #'exp-name #'bind-name))] - [_ - (raise-syntax-error #f "expected identifier or pair of identifiers" - #'orig-stx thing-stx)]))] + (process-imports #'orig-stx (syntax->list #'(import ...)))] [mpi-var-defn (let ([phase (sub1 (variable-reference->phase (#%variable-reference)))]) (if (zero? phase) ;; `define-runtime-module-path-index' works right at phase-level 0: #'(define-runtime-module-path-index mpi-var (quote modpath)) ;; need a submodule: - (with-syntax ([lazy-require-path-n - (string->symbol - (format "lazy-require-path-~a-~a" - phase - counter))] + (with-syntax ([lazy-require-path-n (gen-aux-mod-name phase)] ;; May need to adjust modpath, since we're interpreting it ;; relative to a *submodule* of the original context. ;; ie, module-path interpretation is not hygienic! @@ -111,3 +115,81 @@ (variable-reference->resolved-module-path vr))))]) (when (path? path) (register-external-module path #:indirect? #t)))) + +;; ---- + +(define-syntax (lazy-require-syntax stx) + (syntax-case stx () + [(_ [modpath (import ...)] ...) + #`(begin (lazy-require-syntax1/rename modpath (import ...) #,stx) ...)])) + +#| +;; Implementation 1: syntax-local-value to get macro transformer + +;; This version only works for "standard" macros. It doesn't work with +;; set!-transformers. It only supports the macro-nature of syntax +;; bindings like struct names (you can use them as constructors, but not +;; as match patterns). + +(define-syntax (lazy-require-syntax1/transformer stx) + (syntax-case stx () + [(_ modpath (import ...) orig-stx) + (with-syntax ([modpath* (module-path-add-submod-up #'modpath)] + [((exp-name bind-name) ...) + (process-imports #'orig-stx (syntax->list #'(import ...)))] + [aux-mod1 (gen-aux-mod-name '*)] + [aux-mod2 (gen-aux-mod-name '*)]) + (with-syntax ([(get-tx ...) (generate-temporaries #'(exp-name ...))]) + #'(begin + (module aux-mod1 racket/base + (require (only-in (for-template modpath*) exp-name ...)) + (define (get-tx) (syntax-local-value (quote-syntax exp-name))) ... + (provide get-tx ...)) + (module aux-mod2 racket/base + (require (only-in racket/lazy-require lazy-require)) + (lazy-require [(submod ".." aux-mod1) (get-tx ...)]) + (provide get-tx ...)) + (require (for-syntax (only-in (submod "." aux-mod2) [get-tx get-tx] ...))) + (define-syntax (bind-name stx) ((get-tx) stx)) ...)))])) +|# + +;; Implementation 2: lazy rename-transformers + +;; This version is more flexible, since rename-transformers support +;; ordinary variables and syntax bindings other than or more than macros +;; (eg struct information). + +(begin-for-syntax + (struct lazy-rename-transformer (get-id) + #:property prop:rename-transformer + (lambda (self) + (syntax-property ((lazy-rename-transformer-get-id self)) + 'not-free-identifier=? #t)))) + +(define-syntax (lazy-require-syntax1/rename stx) + (syntax-case stx () + [(_ modpath (import ...) orig-stx) + (with-syntax ([modpath* (module-path-add-submod-up #'modpath)] + [((exp-name bind-name) ...) + (process-imports #'orig-stx (syntax->list #'(import ...)))] + [aux-mod1 (gen-aux-mod-name '*)] + [aux-mod2 (gen-aux-mod-name '*)]) + (with-syntax ([(get-id ...) (generate-temporaries #'(exp-name ...))] + [(bind-aux ...) (generate-temporaries #'(bind-name ...))]) + #'(begin + (module aux-mod1 racket/base + (#%require (for-template (only modpath* exp-name ...))) + (define (get-id) (quote-syntax exp-name)) ... + (provide get-id ...)) + (module aux-mod2 racket/base + (require (only-in racket/lazy-require lazy-require)) + (lazy-require [(submod ".." aux-mod1) (get-id ...)]) + (provide get-id ...)) + (require (for-syntax (only-in (submod "." aux-mod2) [get-id get-id] ...))) + ;; Use extra indirection (bind-name -> bind-aux) so that (provide bind-name) + ;; doesn't force (get-id) trying to decide whether to bypass renamer. + (define-syntax bind-aux (lazy-rename-transformer get-id)) ... + (define-syntax bind-name + (make-rename-transformer + (syntax-property (quote-syntax bind-aux) 'not-free-identifier=? #t))) + ...)))]))