diff --git a/pkgs/racket-test-core/tests/racket/stx.rktl b/pkgs/racket-test-core/tests/racket/stx.rktl index 8a27d46d8a..00b42924ea 100644 --- a/pkgs/racket-test-core/tests/racket/stx.rktl +++ b/pkgs/racket-test-core/tests/racket/stx.rktl @@ -2145,6 +2145,57 @@ (syntax-test #'(evil-via-shadower (m))) (syntax-test #'(evil-via-delta-introducer (m))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check that `syntax-make-delta-introducer` transfers +;; shifts along with scopes [example by Alexis] + +(let ([m '(module defines-introducer-to-submodule-binding racket/base + (provide foo-val) + + (module foo racket/base + (provide foo) + (define foo 42)) + + (module introducer racket/base + (require (for-syntax racket/base + racket/syntax) + syntax/parse/define) + + (provide begin-foo) + + (begin-for-syntax + (define scopeless-stx (datum->syntax #f #f))) + + (define-syntax-parser define-cached-require-introducer + [(_ x:id mod-path) + #:with scoped-stx (syntax-local-introduce #'mod-path) + #'(begin + (require scoped-stx) + (begin-for-syntax + (define x (make-syntax-delta-introducer (quote-syntax scoped-stx) scopeless-stx))))]) + + (define-cached-require-introducer introduce-foo (submod ".." foo)) + + (define-syntax-parser begin-foo + [(_ form ...) + (introduce-foo + #'(begin form ...))])) + + (require 'introducer) + (define foo-val (begin-foo foo)))]) + (eval (expand m))) + +(test 42 dynamic-require ''defines-introducer-to-submodule-binding 'foo-val) + +(module uses-introducer-to-submodule-binding racket/base + (provide also-foo-val) + + (require (submod 'defines-introducer-to-submodule-binding introducer)) + + (define also-foo-val (begin-foo foo))) + +(test 42 dynamic-require ''uses-introducer-to-submodule-binding 'also-foo-val) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Check that a for-syntax reference can precede a ;; for-syntax definition diff --git a/racket/src/expander/expand/module.rkt b/racket/src/expander/expand/module.rkt index c48aeb478d..cbd41ade14 100644 --- a/racket/src/expander/expand/module.rkt +++ b/racket/src/expander/expand/module.rkt @@ -118,7 +118,7 @@ (define enclosing-mod (and enclosing-self (module-path-index-join '(submod "..") self))) - (when (and enclosing-mod mpis-for-enclosing-reset) + (when (and #;enclosing-mod mpis-for-enclosing-reset) (set-box! mpis-for-enclosing-reset (cons enclosing-mod (unbox mpis-for-enclosing-reset)))) diff --git a/racket/src/expander/expand/syntax-local.rkt b/racket/src/expander/expand/syntax-local.rkt index 3cf08e2058..208286ae3e 100644 --- a/racket/src/expander/expand/syntax-local.rkt +++ b/racket/src/expander/expand/syntax-local.rkt @@ -143,12 +143,13 @@ (seteq)))) (define delta-scs (set->list (set-subtract ext-scs use-base-scs))) (define maybe-taint (if (syntax-clean? ext-s) values syntax-taint)) + (define shifts (syntax-mpi-shifts ext-s)) (lambda (s [mode 'add]) (maybe-taint (case mode - [(add) (add-scopes s delta-scs)] + [(add) (syntax-add-shifts (add-scopes s delta-scs) shifts #:non-source? #t)] [(remove) (remove-scopes s delta-scs)] - [(flip) (flip-scopes s delta-scs)] + [(flip) (syntax-add-shifts (flip-scopes s delta-scs) shifts #:non-source? #t)] [else (raise-argument-error 'syntax-introducer "(or/c 'add 'remove 'flip)" mode)])))) (define/who (syntax-local-make-delta-introducer id-stx) diff --git a/racket/src/racket/src/startup.inc b/racket/src/racket/src/startup.inc index 4128085b0a..202827220f 100644 --- a/racket/src/racket/src/startup.inc +++ b/racket/src/racket/src/startup.inc @@ -45661,6 +45661,7 @@ static const char *startup_source = "(set->list(set-subtract ext-scs_0 use-base-scs_0))))" "(let-values(((maybe-taint_0)" "(if(syntax-clean? ext-s_0) values syntax-taint$1)))" +"(let-values(((shifts_0)(syntax-mpi-shifts ext-s_0)))" "(let-values(((core78_0)" "(lambda(s77_0 mode76_0)" "(begin" @@ -45672,21 +45673,42 @@ static const char *startup_source = "(let-values(((tmp_0) mode_0))" "(if(equal? tmp_0 'add)" "(let-values()" -"(add-scopes s_0 delta-scs_0))" +"(let-values(((temp80_0)" +"(add-scopes" +" s_0" +" delta-scs_0))" +"((shifts81_0) shifts_0)" +"((temp82_0) #t))" +"(syntax-add-shifts44.1" +" temp82_0" +" temp80_0" +" shifts81_0" +" #f)))" "(if(equal? tmp_0 'remove)" "(let-values()" "(remove-scopes s_0 delta-scs_0))" "(if(equal? tmp_0 'flip)" "(let-values()" -"(flip-scopes s_0 delta-scs_0))" +"(let-values(((temp83_0)" +"(flip-scopes" +" s_0" +" delta-scs_0))" +"((shifts84_0)" +" shifts_0)" +"((temp85_0) #t))" +"(syntax-add-shifts44.1" +" temp85_0" +" temp83_0" +" shifts84_0" +" #f)))" "(let-values()" "(raise-argument-error" " 'syntax-introducer" -" \"(or/c 'add 'remove 'flip)\"" +" \"(or/c 'add 'remove 'flip)\"" " mode_0))))))))))))))" "(case-lambda" "((s_0)(core78_0 s_0 'add))" -"((s_0 mode76_0)(core78_0 s_0 mode76_0))))))))))))))))))))))" +"((s_0 mode76_0)(core78_0 s_0 mode76_0)))))))))))))))))))))))" "(case-lambda" "((ext-s_0 base-s_0)" "(begin 'make-syntax-delta-introducer(make-syntax-delta-introducer7_0 ext-s_0 base-s_0 unsafe-undefined)))" @@ -45747,24 +45769,24 @@ static const char *startup_source = "(let-values()(raise-argument-error who_0 intdefs-or-false?-string intdefs_0)))" "(values))))" "(let-values(((current-ctx_0)" -"(let-values(((who81_0) who_0))(get-current-expand-context18.1 #f who81_0))))" +"(let-values(((who87_0) who_0))(get-current-expand-context18.1 #f who87_0))))" "(let-values(((ctx_0)" "(if intdefs_0" "(let-values(((v_0) current-ctx_0))" "(let-values(((the-struct_0) v_0))" "(if(expand-context/outer? the-struct_0)" -"(let-values(((env82_0)" +"(let-values(((env88_0)" "(add-intdef-bindings" "(expand-context-env current-ctx_0)" " intdefs_0))" -"((inner83_0)(root-expand-context/outer-inner v_0)))" +"((inner89_0)(root-expand-context/outer-inner v_0)))" "(expand-context/outer1.1" -" inner83_0" +" inner89_0" "(root-expand-context/outer-post-expansion the-struct_0)" "(root-expand-context/outer-use-site-scopes the-struct_0)" "(root-expand-context/outer-frame-id the-struct_0)" "(expand-context/outer-context the-struct_0)" -" env82_0" +" env88_0" "(expand-context/outer-scopes the-struct_0)" "(expand-context/outer-def-ctx-scopes the-struct_0)" "(expand-context/outer-binding-layer the-struct_0)" @@ -45794,17 +45816,17 @@ static const char *startup_source = " 'loop" "(let-values(((b_0)" "(if immediate?_0" -"(let-values(((id84_0) id_1)" -"((phase85_0) phase_0)" -"((temp86_0) #t))" +"(let-values(((id90_0) id_1)" +"((phase91_0) phase_0)" +"((temp92_0) #t))" "(resolve+shift28.1" " #f" " #f" " null" -" temp86_0" +" temp92_0" " #f" -" id84_0" -" phase85_0))" +" id90_0" +" phase91_0))" "(resolve+shift/extra-inspector" " id_1" " phase_0" @@ -45833,16 +45855,16 @@ static const char *startup_source = " (error who_0 \"unbound identifier: ~v\" id_1))))" "(let-values()" "(let-values(((v_0 primitive?_0 insp_0 protected?_0)" -"(let-values(((b87_0) b_0)" -"((ctx88_0) ctx_0)" -"((id89_0) id_1)" -"((temp90_0) #t))" +"(let-values(((b93_0) b_0)" +"((ctx94_0) ctx_0)" +"((id95_0) id_1)" +"((temp96_0) #t))" "(lookup62.1" " #f" -" temp90_0" -" b87_0" -" ctx88_0" -" id89_0))))" +" temp96_0" +" b93_0" +" ctx94_0" +" id95_0))))" "(if(let-values(((or-part_0)(variable? v_0)))" "(if or-part_0 or-part_0(core-form? v_0)))" "(let-values()" @@ -45902,12 +45924,17 @@ static const char *startup_source = "(let-values(((failure-thunk_0) failure-thunk18_0))" "(let-values(((intdef_0) intdef19_0))" "(let-values()" -"(let-values(((temp91_0) 'syntax-local-value)" -"((temp92_0) #f)" -"((id93_0) id_0)" -"((intdef94_0) intdef_0)" -"((failure-thunk95_0) failure-thunk_0))" -"(do-syntax-local-value15.1 temp92_0 temp91_0 id93_0 intdef94_0 failure-thunk95_0))))))))))" +"(let-values(((temp97_0) 'syntax-local-value)" +"((temp98_0) #f)" +"((id99_0) id_0)" +"((intdef100_0) intdef_0)" +"((failure-thunk101_0) failure-thunk_0))" +"(do-syntax-local-value15.1" +" temp98_0" +" temp97_0" +" id99_0" +" intdef100_0" +" failure-thunk101_0))))))))))" "(case-lambda" "((id_0)(begin 'syntax-local-value(syntax-local-value21_0 id_0 #f #f)))" "((id_0 failure-thunk_0 intdef19_0)(syntax-local-value21_0 id_0 failure-thunk_0 intdef19_0))" @@ -45922,17 +45949,17 @@ static const char *startup_source = "(let-values(((failure-thunk_0) failure-thunk23_0))" "(let-values(((intdef_0) intdef24_0))" "(let-values()" -"(let-values(((temp96_0) 'syntax-local-value/immediate)" -"((temp97_0) #t)" -"((id98_0) id_0)" -"((intdef99_0) intdef_0)" -"((failure-thunk100_0) failure-thunk_0))" +"(let-values(((temp102_0) 'syntax-local-value/immediate)" +"((temp103_0) #t)" +"((id104_0) id_0)" +"((intdef105_0) intdef_0)" +"((failure-thunk106_0) failure-thunk_0))" "(do-syntax-local-value15.1" -" temp97_0" -" temp96_0" -" id98_0" -" intdef99_0" -" failure-thunk100_0))))))))))" +" temp103_0" +" temp102_0" +" id104_0" +" intdef105_0" +" failure-thunk106_0))))))))))" "(case-lambda" "((id_0)(begin 'syntax-local-value/immediate(syntax-local-value/immediate26_0 id_0 #f #f)))" "((id_0 failure-thunk_0 intdef24_0)(syntax-local-value/immediate26_0 id_0 failure-thunk_0 intdef24_0))" @@ -45951,7 +45978,7 @@ static const char *startup_source = "(void)" " (let-values () (raise-argument-error who_0 \"exact-nonnegative-integer?\" n_0)))" "(values))))" -"(let-values(((ctx_0)(let-values(((who101_0) who_0))(get-current-expand-context18.1 #f who101_0))))" +"(let-values(((ctx_0)(let-values(((who107_0) who_0))(get-current-expand-context18.1 #f who107_0))))" "(let-values(((lifts_0)(expand-context-lifts ctx_0)))" "(let-values((()" "(begin" @@ -46038,8 +46065,8 @@ static const char *startup_source = "(let-values()" "(let-values()" "(let-values(((ctx_0)" -"(let-values(((who105_0) 'syntax-local-lift-context))" -"(get-current-expand-context18.1 #f who105_0))))" +"(let-values(((who111_0) 'syntax-local-lift-context))" +"(get-current-expand-context18.1 #f who111_0))))" "(root-expand-context-lift-key ctx_0)))))))" "(define-values" "(1/syntax-local-lift-module)" @@ -46055,8 +46082,8 @@ static const char *startup_source = " (let-values () (raise-argument-error 'syntax-local-lift-module \"syntax?\" s_0)))" "(values))))" "(let-values(((ctx_0)" -"(let-values(((who107_0) 'syntax-local-lift-module))" -"(get-current-expand-context18.1 #f who107_0))))" +"(let-values(((who113_0) 'syntax-local-lift-module))" +"(get-current-expand-context18.1 #f who113_0))))" "(let-values(((phase_0)(expand-context-phase ctx_0)))" "(begin" "(let-values(((tmp_0)(core-form-sym s_0 phase_0)))" @@ -46123,8 +46150,8 @@ static const char *startup_source = "(values))))" "(let-values((()(begin(more-checks_0)(values))))" "(let-values(((ctx_0)" -"(let-values(((who108_0) who_0))" -"(get-current-expand-context18.1 #f who108_0))))" +"(let-values(((who114_0) who_0))" +"(get-current-expand-context18.1 #f who114_0))))" "(let-values(((lift-ctx_0)(get-lift-ctx_0 ctx_0)))" "(let-values((()" "(begin" @@ -46193,36 +46220,36 @@ static const char *startup_source = "(let-values()" "(let-values(((sc_0)(new-scope 'lifted-require)))" "(let-values(((ctx_0 added-s_0)" -"(let-values(((who110_0) 'syntax-local-lift-require)" -"((temp111_0)(datum->syntax$1 #f s_0))" -" ((temp112_0) \"could not find target context\")" -"((temp113_0) #f)" -"((temp114_0)" +"(let-values(((who116_0) 'syntax-local-lift-require)" +"((temp117_0)(datum->syntax$1 #f s_0))" +" ((temp118_0) \"could not find target context\")" +"((temp119_0) #f)" +"((temp120_0)" "(lambda()" "(if(syntax?$1 use-s_0)" "(void)" "(let-values()" " (raise-argument-error 'syntax-local-lift-require \"syntax?\" use-s_0)))))" -"((expand-context-require-lifts115_0) expand-context-require-lifts)" -"((require-lift-context-wrt-phase116_0) require-lift-context-wrt-phase)" -"((add-lifted-require!117_0) add-lifted-require!)" -"((temp118_0)" +"((expand-context-require-lifts121_0) expand-context-require-lifts)" +"((require-lift-context-wrt-phase122_0) require-lift-context-wrt-phase)" +"((add-lifted-require!123_0) add-lifted-require!)" +"((temp124_0)" "(lambda(s_1 phase_0 require-lift-ctx_0)(require-spec-shift-for-syntax s_1)))" -"((temp119_0)" +"((temp125_0)" "(lambda(s_1 phase_0 require-lift-ctx_0)" "(wrap-form '#%require(add-scope s_1 sc_0) phase_0))))" "(do-local-lift-to-module48.1" -" add-lifted-require!117_0" -" expand-context-require-lifts115_0" -" require-lift-context-wrt-phase116_0" -" temp113_0" -" temp114_0" -" temp112_0" +" add-lifted-require!123_0" +" expand-context-require-lifts121_0" +" require-lift-context-wrt-phase122_0" " temp119_0" -" unsafe-undefined" +" temp120_0" " temp118_0" -" who110_0" -" temp111_0))))" +" temp125_0" +" unsafe-undefined" +" temp124_0" +" who116_0" +" temp117_0))))" "(let-values((()" "(begin" "(namespace-visit-available-modules!" @@ -46245,28 +46272,28 @@ static const char *startup_source = "(let-values()" "(let-values()" "(let-values(((ctx_0 result-s_0)" -"(let-values(((who121_0) 'syntax-local-lift-provide)" -"((s122_0) s_0)" -" ((temp123_0) \"not expanding in a module run-time body\")" -"((expand-context-to-module-lifts124_0) expand-context-to-module-lifts)" -"((to-module-lift-context-wrt-phase125_0) to-module-lift-context-wrt-phase)" -"((add-lifted-to-module-provide!126_0) add-lifted-to-module-provide!)" -"((temp127_0)" +"(let-values(((who127_0) 'syntax-local-lift-provide)" +"((s128_0) s_0)" +" ((temp129_0) \"not expanding in a module run-time body\")" +"((expand-context-to-module-lifts130_0) expand-context-to-module-lifts)" +"((to-module-lift-context-wrt-phase131_0) to-module-lift-context-wrt-phase)" +"((add-lifted-to-module-provide!132_0) add-lifted-to-module-provide!)" +"((temp133_0)" "(lambda(s_1 phase_0 to-module-lift-ctx_0)(wrap-form 'for-syntax s_1 #f)))" -"((temp128_0)" +"((temp134_0)" "(lambda(s_1 phase_0 to-module-lift-ctx_0)(wrap-form '#%provide s_1 phase_0))))" "(do-local-lift-to-module48.1" -" add-lifted-to-module-provide!126_0" -" expand-context-to-module-lifts124_0" -" to-module-lift-context-wrt-phase125_0" +" add-lifted-to-module-provide!132_0" +" expand-context-to-module-lifts130_0" +" to-module-lift-context-wrt-phase131_0" " #t" " unsafe-undefined" -" temp123_0" -" temp128_0" +" temp129_0" +" temp134_0" " unsafe-undefined" -" temp127_0" -" who121_0" -" s122_0))))" +" temp133_0" +" who127_0" +" s128_0))))" "(let-values(((obs_0)(expand-context-observer ctx_0)))" "(if obs_0" "(let-values()(let-values()(call-expand-observe obs_0 'lift-provide result-s_0)))" @@ -46279,33 +46306,33 @@ static const char *startup_source = "(let-values()" "(let-values()" "(let-values(((ctx_0 also-s_0)" -"(let-values(((who130_0) 'syntax-local-lift-module-end-declaration)" -"((s131_0) s_0)" -"((temp132_0)" +"(let-values(((who136_0) 'syntax-local-lift-module-end-declaration)" +"((s137_0) s_0)" +"((temp138_0)" " \"not currently transforming an expression within a module declaration\")" -"((expand-context-to-module-lifts133_0) expand-context-to-module-lifts)" -"((temp134_0)(lambda(lift-ctx_0) 0))" -"((add-lifted-to-module-end!135_0) add-lifted-to-module-end!)" -"((temp136_0)" +"((expand-context-to-module-lifts139_0) expand-context-to-module-lifts)" +"((temp140_0)(lambda(lift-ctx_0) 0))" +"((add-lifted-to-module-end!141_0) add-lifted-to-module-end!)" +"((temp142_0)" "(lambda(orig-s_0 phase_0 to-module-lift-ctx_0)" "(if(to-module-lift-context-end-as-expressions? to-module-lift-ctx_0)" "(wrap-form '#%expression orig-s_0 phase_0)" " orig-s_0)))" -"((temp137_0)" +"((temp143_0)" "(lambda(s_1 phase_0 to-module-lift-ctx_0)" "(wrap-form 'begin-for-syntax s_1 phase_0))))" "(do-local-lift-to-module48.1" -" add-lifted-to-module-end!135_0" -" expand-context-to-module-lifts133_0" -" temp134_0" +" add-lifted-to-module-end!141_0" +" expand-context-to-module-lifts139_0" +" temp140_0" " #t" " unsafe-undefined" -" temp132_0" +" temp138_0" " unsafe-undefined" -" temp136_0" -" temp137_0" -" who130_0" -" s131_0))))" +" temp142_0" +" temp143_0" +" who136_0" +" s137_0))))" "(let-values(((obs_0)(expand-context-observer ctx_0)))" "(if obs_0(let-values()(let-values()(call-expand-observe obs_0 'lift-statement s_0)))(void)))))))))" "(define-values" @@ -46332,8 +46359,8 @@ static const char *startup_source = " \"not currently transforming module provides\")))" "(values))))" "(let-values(((ctx_0)" -"(let-values(((temp139_0) 'syntax-local-module-defined-identifiers))" -"(get-current-expand-context18.1 #f temp139_0))))" +"(let-values(((temp145_0) 'syntax-local-module-defined-identifiers))" +"(get-current-expand-context18.1 #f temp145_0))))" "(requireds->phase-ht(extract-module-definitions(expand-context-requires+provides ctx_0))))))))))" "(define-values" "(1/syntax-local-module-required-identifiers)" @@ -46374,8 +46401,8 @@ static const char *startup_source = " \"not currently transforming module provides\")))" "(values))))" "(let-values(((ctx_0)" -"(let-values(((temp141_0) 'syntax-local-module-required-identifiers))" -"(get-current-expand-context18.1 #f temp141_0))))" +"(let-values(((temp147_0) 'syntax-local-module-required-identifiers))" +"(get-current-expand-context18.1 #f temp147_0))))" "(let-values(((requires+provides_0)(expand-context-requires+provides ctx_0)))" "(let-values(((mpi_0)(if mod-path_0(module-path->mpi/context mod-path_0 ctx_0) #f)))" "(let-values(((requireds_0)" @@ -46466,8 +46493,8 @@ static const char *startup_source = " mod-path_0)))" "(values))))" "(let-values(((ctx_0)" -"(let-values(((temp143_0) 'syntax-local-module-exports))" -"(get-current-expand-context18.1 #f temp143_0))))" +"(let-values(((temp149_0) 'syntax-local-module-exports))" +"(get-current-expand-context18.1 #f temp149_0))))" "(let-values(((ns_0)(expand-context-namespace ctx_0)))" "(let-values(((mod-name_0)" "(1/module-path-index-resolve" @@ -46560,8 +46587,8 @@ static const char *startup_source = "(let-values()" "(let-values()" "(let-values(((ctx_0)" -"(let-values(((who145_0) 'syntax-local-submodules))" -"(get-current-expand-context18.1 #f who145_0))))" +"(let-values(((who151_0) 'syntax-local-submodules))" +"(get-current-expand-context18.1 #f who151_0))))" "(let-values(((submods_0)(expand-context-declared-submodule-names ctx_0)))" "(reverse$1" "(let-values(((ht_0) submods_0))" @@ -46612,8 +46639,8 @@ static const char *startup_source = " (raise-argument-error 'syntax-local-get-shadower \"identifier?\" id_0)))" "(values))))" "(let-values(((ctx_0)" -"(let-values(((who147_0) 'syntax-local-get-shadower))" -"(get-current-expand-context18.1 #f who147_0))))" +"(let-values(((who153_0) 'syntax-local-get-shadower))" +"(get-current-expand-context18.1 #f who153_0))))" "(let-values(((new-id_0)(add-scopes id_0(expand-context-scopes ctx_0))))" "(if(syntax-clean? id_0) new-id_0(syntax-taint$1 new-id_0))))))))))))))" "(case-lambda" @@ -76139,7 +76166,7 @@ static const char *startup_source = " #f)))" "(let-values((()" "(begin" -"(if(if enclosing-mod_0 mpis-for-enclosing-reset_0 #f)" +"(if mpis-for-enclosing-reset_0" "(let-values()" "(set-box!" " mpis-for-enclosing-reset_0"