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

fix tainting issue

Browse Source
This commit is contained in:
Spencer Florence 2015-01-22 20:56:56 -05:00
parent 14175fc208
commit e5aabb5cc5
1 changed files with 22 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
strace.rkt
View File

@ -66,17 +66,26 @@
(define-runtime-path coverage.rkt "coverage.rkt")
(define (add-cover-require expr [top #t])
(syntax-parse expr
#:literal-sets (kernel-literals)
[(module name lang (#%module-begin b ...))
(with-syntax ([cover cover-name]
[srcloc srcloc-name]
[(body ...) (map (lambda (e) (add-cover-require e #f)) (syntax->list #'(b ...)))])
(namespace-syntax-introduce
(quasisyntax/loc expr
(module name lang
(#%module-begin
(#%require (rename (file #,(->absolute coverage.rkt)) cover coverage))
(#%require (rename racket/base srcloc make-srcloc))
body ...)))))]
(define inspector (variable-reference->module-declaration-inspector
(#%variable-reference)))
(syntax-parse (syntax-disarm expr inspector)
#:literal-sets (kernel-literals)
[(module name lang mb)
(with-syntax ([cover cover-name]
[srcloc srcloc-name]
)
(syntax-parse (syntax-disarm #'mb inspector)
#:literal-sets (kernel-literals)
[(#%module-begin b ...)
(with-syntax ([(body ...)
(map (lambda (e) (add-cover-require e #f)) (syntax->list #'(b ...)))])
(syntax-rearm
(namespace-syntax-introduce
(quasisyntax/loc expr
(module name lang
(#%module-begin
(#%require (rename (file #,(->absolute coverage.rkt)) cover coverage))
(#%require (rename racket/base srcloc make-srcloc))
body ...))))
expr))]))]
[_ (if top #f expr)]))