suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

expander: attach original property to #%app made explicit

Browse Source 
Copy any syntax-original property from the parentheses assodictaed
with a `#%app` made explicit, so that originalness is tracked in
the 'origin property.
This commit is contained in:
Matthew Flatt 2020-12-12 08:19:58 -07:00
parent 426b6adc79
commit e7cef677ad
6 changed files with 193 additions and 117 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
pkgs/racket-test-core/tests/racket/macro.rktl
View File

@ -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))

89
racket/src/bc/src/startup.inc
View File

@ -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)"

139
racket/src/cs/schemified/expander.scm
View File

@ -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

10
racket/src/expander/expand/main.rkt
View File

@ -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)

10
racket/src/expander/syntax/property.rkt
View File

@ -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))

46
racket/src/expander/syntax/syntax.rkt
View File

@ -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