diff --git a/pkgs/racket-test-core/tests/racket/macro.rktl b/pkgs/racket-test-core/tests/racket/macro.rktl index 25ddf9c41e..90dbb87ad6 100644 --- a/pkgs/racket-test-core/tests/racket/macro.rktl +++ b/pkgs/racket-test-core/tests/racket/macro.rktl @@ -1046,6 +1046,22 @@ (sloop (car stx) in-prop?) (sloop (cdr stx) in-prop?)]))) +;; ---------------------------------------- +;; Check that an implicitly introduced #%app has the same +;; `syntax-original?` as its parenthesized form + +(let ([find (lambda (e sym) + (let loop ([s (syntax-property e 'origin)]) + (cond + [(and (identifier? s) + (eq? sym (syntax-e s))) + s] + [(pair? s) (or (loop (car s)) (loop (cdr s)))] + [else #f])))]) + ;; expecting `#%app` from `racket/base` to reqrite to core `#%app` + (test #t syntax-original? (find (expand #'(+ 1 2)) '#%app)) + (test #f syntax-original? (find (expand (datum->syntax #'here '(+ 1 2))) '#%app))) + ;; ---------------------------------------- (err/rt-test (syntax-local-lift-require 'abc #'def)) diff --git a/racket/src/bc/src/startup.inc b/racket/src/bc/src/startup.inc index c3e201fdaf..405098e321 100644 --- a/racket/src/bc/src/startup.inc +++ b/racket/src/bc/src/startup.inc @@ -6299,6 +6299,33 @@ static const char *startup_source = " s_1)))))" "(define-values(cell.1$7)(unsafe-make-place-local(make-weak-hasheq)))" "(define-values" +"(immediate-datum->syntax)" +"(lambda(stx-c_0 content_0 stx-l_0 props_0 insp_0)" +"(begin" +"(syntax2.1" +"(if(if stx-c_0(syntax-tamper stx-c_0) #f)" +"(modified-content1.1 content_0(tamper-tainted-for-content content_0))" +" content_0)" +"(if stx-c_0(syntax-scopes stx-c_0) empty-scopes)" +"(if stx-c_0(syntax-shifted-multi-scopes stx-c_0) empty-shifted-multi-scopes)" +"(if stx-c_0(syntax-mpi-shifts stx-c_0) empty-mpi-shifts)" +"(if stx-l_0(syntax-srcloc stx-l_0) #f)" +" props_0" +"(if insp_0" +"(if stx-c_0" +"(let-values(((a_0) insp_0)((b_0)(syntax-inspector stx-c_0)))" +"(if(eq? a_0 b_0)" +"(let-values() a_0)" +"(if(not a_0)" +"(let-values() #f)" +"(if(not b_0)" +"(let-values() #f)" +"(if(inspector-superior? a_0 b_0)" +"(let-values() b_0)" +"(if(inspector-superior? b_0 a_0)(let-values() a_0)(let-values() #f)))))))" +" #f)" +" #f)))))" +"(define-values" "(datum->syntax$1)" "(let-values(((datum->syntax_0)" "(lambda(stx-c5_0 s6_0 stx-l3_0 stx-p4_0)" @@ -6319,36 +6346,12 @@ static const char *startup_source = "(begin" " 'wrap" "(let-values(((content_1)(datum-intern-literal content_0)))" -"(syntax2.1" -"(if(if stx-c_0(syntax-tamper stx-c_0) #f)" -"(modified-content1.1" +"(immediate-datum->syntax" +" stx-c_0" " content_1" -"(tamper-tainted-for-content content_1))" -" content_1)" -"(if stx-c_0(syntax-scopes stx-c_0) empty-scopes)" -"(if stx-c_0" -"(syntax-shifted-multi-scopes stx-c_0)" -" empty-shifted-multi-scopes)" -"(if stx-c_0(syntax-mpi-shifts stx-c_0) empty-mpi-shifts)" -"(if stx-l_0(syntax-srcloc stx-l_0) #f)" +" stx-l_0" " empty-props" -"(if insp_0" -"(if stx-c_0" -"(let-values(((a_0) insp_0)" -"((b_0)(syntax-inspector stx-c_0)))" -"(if(eq? a_0 b_0)" -"(let-values() a_0)" -"(if(not a_0)" -"(let-values() #f)" -"(if(not b_0)" -"(let-values() #f)" -"(if(inspector-superior? a_0 b_0)" -"(let-values() b_0)" -"(if(inspector-superior? b_0 a_0)" -"(let-values() a_0)" -"(let-values() #f)))))))" -" #f)" -" #f)))))))" +" insp_0))))))" "(let-values(((result-s_0)" "(let-values(((s_1) s_0)" "((f_0)" @@ -7961,6 +7964,12 @@ static const char *startup_source = " (raise-argument-error 'struct-copy \"syntax?\" the-struct_0)))" " s_0)))))))" "(define-values" +"(syntax-property-copy)" +"(lambda(from-s_0 key_0)" +"(begin" +"(let-values(((v_0)(hash-ref(syntax-props from-s_0) key_0 #f)))" +"(if v_0(hash-set empty-props key_0 v_0) empty-props)))))" +"(define-values" "(taint-content)" "(lambda(d_0)" "(begin" @@ -44696,11 +44705,29 @@ static const char *startup_source = "(make-explicit)" "(lambda(ctx_0 sym_0 s_0 disarmed-s_0)" "(begin" -"(let-values(((new-s_0)(syntax-rearm$1(datum->syntax$1 disarmed-s_0(cons sym_0 disarmed-s_0) s_0 s_0) s_0)))" +"(let-values(((insp_0)(current-module-code-inspector)))" +"(let-values(((sym-s_0)" +"(immediate-datum->syntax" +" disarmed-s_0" +" sym_0" +" s_0" +"(syntax-property-copy s_0 original-property-sym)" +" insp_0)))" +"(let-values(((new-s_0)" +"(syntax-rearm$1" +"(immediate-datum->syntax" +" disarmed-s_0" +"(cons sym-s_0 disarmed-s_0)" +" s_0" +"(syntax-props s_0)" +" insp_0)" +" s_0)))" "(begin" "(let-values(((obs_0)(expand-context-observer ctx_0)))" -"(if obs_0(let-values()(let-values()(call-expand-observe obs_0 'tag2 new-s_0 disarmed-s_0)))(void)))" -" new-s_0)))))" +"(if obs_0" +"(let-values()(let-values()(call-expand-observe obs_0 'tag2 new-s_0 disarmed-s_0)))" +"(void)))" +" new-s_0)))))))" "(define-values" "(dispatch.1)" "(lambda(fail-non-transformer14_0 t16_0 insp-of-t17_0 s18_0 id19_0 ctx20_0 binding21_0 primitive?22_0 protected?23_0)" diff --git a/racket/src/cs/schemified/expander.scm b/racket/src/cs/schemified/expander.scm index 42a0a2c831..d00070c3b8 100644 --- a/racket/src/cs/schemified/expander.scm +++ b/racket/src/cs/schemified/expander.scm @@ -7744,6 +7744,44 @@ syntax->datum (lambda (s_0) (begin (let ((f_0 procz1)) (loop_0 f_0 s_0))))))) (define cell.1$7 (unsafe-make-place-local (make-weak-hasheq))) +(define immediate-datum->syntax + (lambda (stx-c_0 content_0 stx-l_0 props_0 insp_0) + (let ((app_0 + (if (if stx-c_0 (syntax-tamper stx-c_0) #f) + (modified-content1.1 + content_0 + (tamper-tainted-for-content content_0)) + content_0))) + (let ((app_1 (if stx-c_0 (syntax-scopes stx-c_0) empty-scopes))) + (let ((app_2 + (if stx-c_0 + (syntax-shifted-multi-scopes stx-c_0) + empty-shifted-multi-scopes))) + (let ((app_3 (if stx-c_0 (syntax-mpi-shifts stx-c_0) null))) + (let ((app_4 (if stx-l_0 (syntax-srcloc stx-l_0) #f))) + (syntax2.1 + app_0 + app_1 + app_2 + app_3 + app_4 + props_0 + (if insp_0 + (if stx-c_0 + (let ((b_0 (syntax-inspector stx-c_0))) + (if (eq? insp_0 b_0) + insp_0 + (if (not insp_0) + #f + (if (not b_0) + #f + (if (inspector-superior? insp_0 b_0) + b_0 + (if (inspector-superior? b_0 insp_0) + insp_0 + #f)))))) + #f) + #f))))))))) (define datum->syntax$1 (let ((datum->syntax_0 (letrec ((f_0 @@ -7861,56 +7899,12 @@ (lambda (insp_0 stx-c5_0 stx-l3_0 content_0) (begin (let ((content_1 (datum-intern-literal content_0))) - (let ((app_0 - (if (if stx-c5_0 (syntax-tamper stx-c5_0) #f) - (modified-content1.1 - content_1 - (tamper-tainted-for-content content_1)) - content_1))) - (let ((app_1 - (if stx-c5_0 - (syntax-scopes stx-c5_0) - empty-scopes))) - (let ((app_2 - (if stx-c5_0 - (syntax-shifted-multi-scopes stx-c5_0) - empty-shifted-multi-scopes))) - (let ((app_3 - (if stx-c5_0 - (syntax-mpi-shifts stx-c5_0) - null))) - (let ((app_4 - (if stx-l3_0 - (syntax-srcloc stx-l3_0) - #f))) - (syntax2.1 - app_0 - app_1 - app_2 - app_3 - app_4 - empty-props - (if insp_0 - (if stx-c5_0 - (let ((b_0 - (syntax-inspector stx-c5_0))) - (if (eq? insp_0 b_0) - insp_0 - (if (not insp_0) - #f - (if (not b_0) - #f - (if (inspector-superior? - insp_0 - b_0) - b_0 - (if (inspector-superior? - b_0 - insp_0) - insp_0 - #f)))))) - #f) - #f))))))))))))) + (immediate-datum->syntax + stx-c5_0 + content_1 + stx-l3_0 + empty-props + insp_0))))))) (|#%name| datum->syntax (lambda (stx-c5_0 s6_0 stx-l3_0 stx-p4_0) @@ -9560,6 +9554,10 @@ (syntax-inspector s_0)))))))) (raise-argument-error 'struct-copy "syntax?" s_0)) s_0)))))) +(define syntax-property-copy + (lambda (from-s_0 key_0) + (let ((v_0 (hash-ref (syntax-props from-s_0) key_0 #f))) + (if v_0 (hash-set empty-props key_0 v_0) empty-props)))) (define taint-content (letrec ((procz1 (|#%name| f (lambda (tail?_0 x_0) (begin x_0)))) (gf_0 @@ -18613,7 +18611,7 @@ (define 1/make-set!-transformer (let ((struct:set!-transformer_0 (make-record-type-descriptor* 'set!-transformer #f #f #f #f 1 0))) - (let ((effect2391 + (let ((effect2392 (struct-type-install-properties! struct:set!-transformer_0 'set!-transformer @@ -50959,19 +50957,32 @@ result-s_0)))))))))) (define make-explicit (lambda (ctx_0 sym_0 s_0 disarmed-s_0) - (let ((new-s_0 - (syntax-rearm$1 - (datum->syntax$1 disarmed-s_0 (cons sym_0 disarmed-s_0) s_0 s_0) - s_0))) - (begin - (let ((obs_0 - (begin-unsafe - (expand-context/inner-observer - (root-expand-context/outer-inner ctx_0))))) - (if obs_0 - (call-expand-observe obs_0 'tag2 new-s_0 disarmed-s_0) - (void))) - new-s_0)))) + (let ((insp_0 (current-module-code-inspector))) + (let ((sym-s_0 + (immediate-datum->syntax + disarmed-s_0 + sym_0 + s_0 + (syntax-property-copy s_0 original-property-sym) + insp_0))) + (let ((new-s_0 + (syntax-rearm$1 + (immediate-datum->syntax + disarmed-s_0 + (cons sym-s_0 disarmed-s_0) + s_0 + (syntax-props s_0) + insp_0) + s_0))) + (begin + (let ((obs_0 + (begin-unsafe + (expand-context/inner-observer + (root-expand-context/outer-inner ctx_0))))) + (if obs_0 + (call-expand-observe obs_0 'tag2 new-s_0 disarmed-s_0) + (void))) + new-s_0)))))) (define dispatch.1 (|#%name| dispatch diff --git a/racket/src/expander/expand/main.rkt b/racket/src/expander/expand/main.rkt index 59182b8053..38de243220 100644 --- a/racket/src/expander/expand/main.rkt +++ b/racket/src/expander/expand/main.rkt @@ -8,6 +8,7 @@ "../syntax/taint.rkt" "../syntax/taint-dispatch.rkt" "../syntax/match.rkt" + "../syntax/original.rkt" "../namespace/namespace.rkt" "../namespace/module.rkt" "../namespace/inspector.rkt" @@ -240,7 +241,14 @@ result-s)])) (define (make-explicit ctx sym s disarmed-s) - (define new-s (syntax-rearm (datum->syntax disarmed-s (cons sym disarmed-s) s s) s)) + (define insp (current-module-code-inspector)) + (define sym-s (immediate-datum->syntax disarmed-s sym s + (syntax-property-copy s original-property-sym) + insp)) + (define new-s (syntax-rearm (immediate-datum->syntax disarmed-s (cons sym-s disarmed-s) s + (syntax-props s) + insp) + s)) (log-expand ctx 'tag2 new-s disarmed-s) new-s) diff --git a/racket/src/expander/syntax/property.rkt b/racket/src/expander/syntax/property.rkt index ef80715c66..affeecd587 100644 --- a/racket/src/expander/syntax/property.rkt +++ b/racket/src/expander/syntax/property.rkt @@ -6,7 +6,8 @@ (provide syntax-property syntax-property-preserved? syntax-property-symbol-keys - syntax-property-remove) + syntax-property-remove + syntax-property-copy) ;; ---------------------------------------- @@ -56,3 +57,10 @@ (struct-copy syntax s [props (hash-remove (syntax-props s) key)]) s)) + +;; internal use by expander: +(define (syntax-property-copy from-s key) + (define v (hash-ref (syntax-props from-s) key #f)) + (if v + (hash-set empty-props key v) + empty-props)) diff --git a/racket/src/expander/syntax/syntax.rkt b/racket/src/expander/syntax/syntax.rkt index 453e3f29bb..0076f951f6 100644 --- a/racket/src/expander/syntax/syntax.rkt +++ b/racket/src/expander/syntax/syntax.rkt @@ -26,7 +26,10 @@ syntax->datum datum->syntax - + + immediate-datum->syntax + empty-props + syntax-map non-syntax-map @@ -227,6 +230,27 @@ (define-place-local known-syntax-pairs (make-weak-hasheq)) +(define (immediate-datum->syntax stx-c content stx-l props insp) + (syntax (if (and stx-c + (syntax-tamper stx-c)) + (modified-content content + (tamper-tainted-for-content content)) + content) + (if stx-c + (syntax-scopes stx-c) + empty-scopes) + (if stx-c + (syntax-shifted-multi-scopes stx-c) + empty-shifted-multi-scopes) + (if stx-c + (syntax-mpi-shifts stx-c) + empty-mpi-shifts) + (and stx-l (syntax-srcloc stx-l)) + props + (and insp + stx-c + (weaker-inspector insp (syntax-inspector stx-c))))) + (define (datum->syntax stx-c s [stx-l #f] [stx-p #f]) (cond [(syntax? s) s] @@ -234,25 +258,7 @@ (define insp (if (syntax? s) 'not-needed (current-module-code-inspector))) (define (wrap content) (let ([content (datum-intern-literal content)]) - (syntax (if (and stx-c - (syntax-tamper stx-c)) - (modified-content content - (tamper-tainted-for-content content)) - content) - (if stx-c - (syntax-scopes stx-c) - empty-scopes) - (if stx-c - (syntax-shifted-multi-scopes stx-c) - empty-shifted-multi-scopes) - (if stx-c - (syntax-mpi-shifts stx-c) - empty-mpi-shifts) - (and stx-l (syntax-srcloc stx-l)) - empty-props - (and insp - stx-c - (weaker-inspector insp (syntax-inspector stx-c)))))) + (immediate-datum->syntax stx-c content stx-l empty-props insp))) (define result-s (non-syntax-map s (lambda (tail? x) (cond