defer require and provide expansion to module body
Closes PR 14936
This commit is contained in:
Matthew Flatt
parent
c6802ed107
commit
2d4b4527c0
|
|
@ -1294,6 +1294,12 @@
|
||||||
(dynamic-require tmx 'x)))
|
(dynamic-require tmx 'x)))
|
||||||
(delete-file zo-path))
|
(delete-file zo-path))
|
||||||
|
|
||||||
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
;; Check that `provide` doesn't run enclosed expanders until within a
|
||||||
|
;; module (as opposed to a `#%module-begin` expansion):
|
||||||
|
|
||||||
|
(module check-contract-out-by-itself racket (provide (contract-out)))
|
||||||
|
|
||||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
|
|
||||||
(report-errs)
|
(report-errs)
|
||||||
|
|
|
||||||
|
|
@ -241,161 +241,166 @@
|
||||||
;; require
|
;; require
|
||||||
|
|
||||||
(define-syntax (require stx)
|
(define-syntax (require stx)
|
||||||
(unless (memq (syntax-local-context) '(module module-begin top-level))
|
(case (syntax-local-context)
|
||||||
(raise-syntax-error #f
|
[(module-begin)
|
||||||
"not at module level or top level"
|
(quasisyntax/loc stx (begin #,stx))]
|
||||||
stx))
|
[(module top-level)
|
||||||
(parameterize ([current-require-module-path #f])
|
(parameterize ([current-require-module-path #f])
|
||||||
(letrec ([mode-wrap
|
(letrec ([mode-wrap
|
||||||
(lambda (mode base)
|
(lambda (mode base)
|
||||||
(cond
|
(cond
|
||||||
[(eq? mode 0) base]
|
[(eq? mode 0) base]
|
||||||
[else #`(for-meta #,mode #,base)]))]
|
[else #`(for-meta #,mode #,base)]))]
|
||||||
[simple-path? (lambda (p)
|
[simple-path? (lambda (p)
|
||||||
(syntax-case p (lib quote)
|
(syntax-case p (lib quote)
|
||||||
[(lib . _)
|
[(lib . _)
|
||||||
(check-lib-form p)]
|
(check-lib-form p)]
|
||||||
[(quote . _)
|
[(quote . _)
|
||||||
(check-lib-form p)]
|
(check-lib-form p)]
|
||||||
[_
|
[_
|
||||||
(or (identifier? p)
|
(or (identifier? p)
|
||||||
(and (string? (syntax-e p))
|
(and (string? (syntax-e p))
|
||||||
(module-path? (syntax-e p))))]))]
|
(module-path? (syntax-e p))))]))]
|
||||||
[transform-simple
|
[transform-simple
|
||||||
(lambda (in base-mode)
|
(lambda (in base-mode)
|
||||||
(syntax-case in (lib file planet submod prefix-in except-in quote)
|
(syntax-case in (lib file planet submod prefix-in except-in quote)
|
||||||
;; Detect simple cases first:
|
;; Detect simple cases first:
|
||||||
[_
|
[_
|
||||||
(string? (syntax-e in))
|
(string? (syntax-e in))
|
||||||
(begin
|
(begin
|
||||||
(unless (module-path? (syntax-e in))
|
(unless (module-path? (syntax-e in))
|
||||||
(raise-syntax-error
|
(raise-syntax-error
|
||||||
#f
|
#f
|
||||||
"bad module-path string"
|
"bad module-path string"
|
||||||
stx
|
stx
|
||||||
in))
|
in))
|
||||||
(list (mode-wrap base-mode in)))]
|
(list (mode-wrap base-mode in)))]
|
||||||
[_
|
[_
|
||||||
(and (identifier? in)
|
(and (identifier? in)
|
||||||
(module-path? (syntax-e #'in)))
|
(module-path? (syntax-e #'in)))
|
||||||
(list (mode-wrap base-mode in))]
|
(list (mode-wrap base-mode in))]
|
||||||
[(quote . s)
|
[(quote . s)
|
||||||
(check-lib-form in)
|
(check-lib-form in)
|
||||||
(list (mode-wrap base-mode (xlate-path in)))]
|
(list (mode-wrap base-mode (xlate-path in)))]
|
||||||
[(lib . s)
|
[(lib . s)
|
||||||
(check-lib-form in)
|
(check-lib-form in)
|
||||||
(list (mode-wrap base-mode (xlate-path in)))]
|
(list (mode-wrap base-mode (xlate-path in)))]
|
||||||
[(file . s)
|
[(file . s)
|
||||||
(check-lib-form in)
|
(check-lib-form in)
|
||||||
(list (mode-wrap base-mode (xlate-path in)))]
|
(list (mode-wrap base-mode (xlate-path in)))]
|
||||||
[(planet . s)
|
[(planet . s)
|
||||||
(check-lib-form in)
|
(check-lib-form in)
|
||||||
(list (mode-wrap base-mode (xlate-path in)))]
|
(list (mode-wrap base-mode (xlate-path in)))]
|
||||||
[(submod . s)
|
[(submod . s)
|
||||||
(check-lib-form in)
|
(check-lib-form in)
|
||||||
(list (mode-wrap base-mode (xlate-path in)))]
|
(list (mode-wrap base-mode (xlate-path in)))]
|
||||||
[(prefix-in pfx path)
|
[(prefix-in pfx path)
|
||||||
(simple-path? #'path)
|
(simple-path? #'path)
|
||||||
(list (mode-wrap
|
(list (mode-wrap
|
||||||
base-mode
|
base-mode
|
||||||
(datum->syntax
|
(datum->syntax
|
||||||
#'path
|
#'path
|
||||||
(syntax-e
|
(syntax-e
|
||||||
(quasisyntax
|
(quasisyntax
|
||||||
(prefix pfx #,(xlate-path #'path))))
|
(prefix pfx #,(xlate-path #'path))))
|
||||||
in
|
in
|
||||||
in)))]
|
in)))]
|
||||||
[(except-in path id ...)
|
[(except-in path id ...)
|
||||||
(and (simple-path? #'path)
|
(and (simple-path? #'path)
|
||||||
;; check that it's well-formed...
|
;; check that it's well-formed...
|
||||||
(call-with-values (lambda () (expand-import in))
|
(call-with-values (lambda () (expand-import in))
|
||||||
(lambda (a b) #t)))
|
(lambda (a b) #t)))
|
||||||
(list (mode-wrap
|
(list (mode-wrap
|
||||||
base-mode
|
base-mode
|
||||||
(datum->syntax
|
(datum->syntax
|
||||||
#'path
|
#'path
|
||||||
(syntax-e
|
(syntax-e
|
||||||
(quasisyntax/loc in
|
(quasisyntax/loc in
|
||||||
(all-except #,(xlate-path #'path) id ...))))))]
|
(all-except #,(xlate-path #'path) id ...))))))]
|
||||||
;; General case:
|
;; General case:
|
||||||
[_ (let-values ([(imports sources) (expand-import in)])
|
[_ (let-values ([(imports sources) (expand-import in)])
|
||||||
;; TODO: collapse back to simple cases when possible
|
;; TODO: collapse back to simple cases when possible
|
||||||
(append
|
(append
|
||||||
(map (lambda (import)
|
(map (lambda (import)
|
||||||
#`(just-meta
|
#`(just-meta
|
||||||
#,(import-orig-mode import)
|
#,(import-orig-mode import)
|
||||||
#,(mode-wrap (phase+ base-mode (import-req-mode import))
|
#,(mode-wrap (phase+ base-mode (import-req-mode import))
|
||||||
#`(rename #,(import-src-mod-path import)
|
#`(rename #,(import-src-mod-path import)
|
||||||
#,(import-local-id import)
|
#,(import-local-id import)
|
||||||
#,(import-src-sym import)))))
|
#,(import-src-sym import)))))
|
||||||
imports)
|
imports)
|
||||||
(map (lambda (src)
|
(map (lambda (src)
|
||||||
(mode-wrap (phase+ base-mode (import-source-mode src))
|
(mode-wrap (phase+ base-mode (import-source-mode src))
|
||||||
#`(only #,(import-source-mod-path-stx src))))
|
#`(only #,(import-source-mod-path-stx src))))
|
||||||
sources)))]))]
|
sources)))]))]
|
||||||
[transform-one
|
[transform-one
|
||||||
(lambda (in)
|
(lambda (in)
|
||||||
;; Recognize `for-syntax', etc. for simple cases:
|
;; Recognize `for-syntax', etc. for simple cases:
|
||||||
(syntax-case in (for-meta)
|
(syntax-case in (for-meta)
|
||||||
[(for-meta n elem ...)
|
[(for-meta n elem ...)
|
||||||
(or (exact-integer? (syntax-e #'n))
|
(or (exact-integer? (syntax-e #'n))
|
||||||
(not (syntax-e #'n)))
|
(not (syntax-e #'n)))
|
||||||
(apply append
|
(apply append
|
||||||
(map (lambda (in)
|
(map (lambda (in)
|
||||||
(transform-simple in (syntax-e #'n)))
|
(transform-simple in (syntax-e #'n)))
|
||||||
(syntax->list #'(elem ...))))]
|
(syntax->list #'(elem ...))))]
|
||||||
[(for-something elem ...)
|
[(for-something elem ...)
|
||||||
(and (identifier? #'for-something)
|
(and (identifier? #'for-something)
|
||||||
(ormap (lambda (i) (free-identifier=? i #'for-something))
|
(ormap (lambda (i) (free-identifier=? i #'for-something))
|
||||||
(list #'for-syntax #'for-template #'for-label)))
|
(list #'for-syntax #'for-template #'for-label)))
|
||||||
(apply append
|
(apply append
|
||||||
(map (lambda (in)
|
(map (lambda (in)
|
||||||
(transform-simple in
|
(transform-simple in
|
||||||
(cond
|
(cond
|
||||||
[(free-identifier=? #'for-something #'for-syntax)
|
[(free-identifier=? #'for-something #'for-syntax)
|
||||||
1]
|
1]
|
||||||
[(free-identifier=? #'for-something #'for-template)
|
[(free-identifier=? #'for-something #'for-template)
|
||||||
-1]
|
-1]
|
||||||
[(free-identifier=? #'for-something #'for-label)
|
[(free-identifier=? #'for-something #'for-label)
|
||||||
#f])))
|
#f])))
|
||||||
(syntax->list #'(elem ...))))]
|
(syntax->list #'(elem ...))))]
|
||||||
[_ (transform-simple in 0 #| run phase |#)]))])
|
[_ (transform-simple in 0 #| run phase |#)]))])
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(_ in)
|
[(_ in)
|
||||||
(with-syntax ([(new-in ...) (transform-one #'in)])
|
(with-syntax ([(new-in ...) (transform-one #'in)])
|
||||||
(syntax/loc stx
|
(syntax/loc stx
|
||||||
(#%require new-in ...)))]
|
(#%require new-in ...)))]
|
||||||
[(_ in ...)
|
[(_ in ...)
|
||||||
;; Prefetch on simple module paths:
|
;; Prefetch on simple module paths:
|
||||||
(let ([prefetches
|
(let ([prefetches
|
||||||
(let loop ([in (syntax->list #'(in ...))])
|
(let loop ([in (syntax->list #'(in ...))])
|
||||||
(cond
|
(cond
|
||||||
[(null? in) null]
|
[(null? in) null]
|
||||||
[(let ([a (syntax->datum (car in))])
|
[(let ([a (syntax->datum (car in))])
|
||||||
(and (module-path? a) a))
|
(and (module-path? a) a))
|
||||||
=> (lambda (a)
|
=> (lambda (a)
|
||||||
(cons a (loop (cdr in))))]
|
(cons a (loop (cdr in))))]
|
||||||
[else
|
[else
|
||||||
(let ([a (syntax->list (car in))])
|
(let ([a (syntax->list (car in))])
|
||||||
(if (and a
|
(if (and a
|
||||||
(let ([i (car a)])
|
(let ([i (car a)])
|
||||||
(and (identifier? i)
|
(and (identifier? i)
|
||||||
(or (free-identifier=? #'for-something #'for-syntax)
|
(or (free-identifier=? #'for-something #'for-syntax)
|
||||||
(free-identifier=? #'for-something #'for-template)
|
(free-identifier=? #'for-something #'for-template)
|
||||||
(free-identifier=? #'for-something #'for-label)))))
|
(free-identifier=? #'for-something #'for-label)))))
|
||||||
(loop (append (cdr a) (cdr in)))
|
(loop (append (cdr a) (cdr in)))
|
||||||
(loop (cdr in))))]))])
|
(loop (cdr in))))]))])
|
||||||
(unless (null? prefetches)
|
(unless (null? prefetches)
|
||||||
(log-message (current-logger)
|
(log-message (current-logger)
|
||||||
'info
|
'info
|
||||||
'module-prefetch
|
'module-prefetch
|
||||||
(format "module-prefetch: ~s in: ~s"
|
(format "module-prefetch: ~s in: ~s"
|
||||||
prefetches
|
prefetches
|
||||||
(current-load-relative-directory))
|
(current-load-relative-directory))
|
||||||
(list prefetches (current-load-relative-directory))
|
(list prefetches (current-load-relative-directory))
|
||||||
#f))
|
#f))
|
||||||
(syntax/loc stx
|
(syntax/loc stx
|
||||||
(begin (require in) ...)))]))))
|
(begin (require in) ...)))])))]
|
||||||
|
[else
|
||||||
|
(raise-syntax-error #f
|
||||||
|
"not at module level or top level"
|
||||||
|
stx)]))
|
||||||
|
|
||||||
|
|
||||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; require transformers
|
;; require transformers
|
||||||
|
|
@ -672,22 +677,25 @@
|
||||||
;; provide
|
;; provide
|
||||||
|
|
||||||
(define-syntax (provide stx)
|
(define-syntax (provide stx)
|
||||||
(unless (memq (syntax-local-context) '(module module-begin))
|
(case (syntax-local-context)
|
||||||
(raise-syntax-error #f
|
[(module-begin)
|
||||||
"not at module level"
|
(quasisyntax/loc stx (begin #,stx))]
|
||||||
stx))
|
[(module)
|
||||||
|
(syntax-case stx ()
|
||||||
(syntax-case stx ()
|
[(_ out ...)
|
||||||
[(_ out ...)
|
(with-syntax ([(out ...)
|
||||||
(with-syntax ([(out ...)
|
(map (lambda (o) (pre-expand-export o null))
|
||||||
(map (lambda (o) (pre-expand-export o null))
|
(syntax->list #'(out ...)))])
|
||||||
(syntax->list #'(out ...)))])
|
(syntax-property
|
||||||
(syntax-property
|
(quasisyntax/loc stx
|
||||||
(quasisyntax/loc stx
|
(#%provide #,(syntax-property
|
||||||
(#%provide #,(syntax-property
|
#`(expand (provide-trampoline out ...))
|
||||||
#`(expand (provide-trampoline out ...))
|
'certify-mode 'transparent)))
|
||||||
'certify-mode 'transparent)))
|
'certify-mode 'transparent))])]
|
||||||
'certify-mode 'transparent))]))
|
[else
|
||||||
|
(raise-syntax-error #f
|
||||||
|
"not at module level"
|
||||||
|
stx)]))
|
||||||
|
|
||||||
(define-syntax (provide-trampoline stx)
|
(define-syntax (provide-trampoline stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user