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

fix debugger for syntax taints

Browse Source
This commit is contained in:
Matthew Flatt 2011-07-07 13:37:54 -06:00
parent 68d49e9f59
commit 9bee07b7c0
1 changed files with 20 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
collects/gui-debugger/annotator.rkt
View File

@ -159,14 +159,18 @@
(define (top-level-annotate stx)
(kernel:kernel-syntax-case/phase
stx (namespace-base-phase)
[(module identifier name (plain-module-begin . module-level-exprs))
(with-syntax ([(module . _) stx])
(quasisyntax/loc stx (module identifier name
(plain-module-begin
#,@(map (lambda (e) (module-level-expr-iterator
e (list (syntax-e #'identifier)
(syntax-source #'identifier))))
(syntax->list #'module-level-exprs))))))]
[(module identifier name mb)
(syntax-case (disarm #'mb) ()
[(plain-module-begin . module-level-exprs)
(with-syntax ([(module . _) stx])
(quasisyntax/loc stx (module identifier name
#,(rearm
#'mb
#`(plain-module-begin
#,@(map (lambda (e) (module-level-expr-iterator
e (list (syntax-e #'identifier)
(syntax-source #'identifier))))
(syntax->list #'module-level-exprs)))))))])]
[else-stx
(general-top-level-expr-iterator stx #f)]))
@ -238,7 +242,7 @@
(define (let/rec-values-annotator letrec?)
(kernel:kernel-syntax-case
expr #f
(disarm expr) #f
[(label (((var ...) rhs) ...) . bodies)
(let* ([new-bindings (apply append
(map syntax->list
@ -305,9 +309,10 @@
#,@new-bodies))))]))
(define annotated
(syntax-rearm
(rearm
expr
(kernel:kernel-syntax-case
(syntax-disarm expr code-insp) #f
(disarm expr) #f
[var-stx (identifier? (syntax var-stx))
(let ([binder (and (syntax-original? expr)
(srfi:member expr bound-vars free-identifier=?))])
@ -378,8 +383,7 @@
[(#%variable-reference . _) expr]
[else (error 'expr-syntax-object-iterator "unknown expr: ~a"
(syntax->datum expr))])
expr))
(syntax->datum expr))])))
(if annotate-break?
(break-wrap
@ -391,4 +395,7 @@
(values (top-level-annotate stx) (hash-map breakpoints (lambda (k v) k)))))
(define (disarm stx) (syntax-disarm stx code-insp))
(define (rearm old new) (syntax-rearm new old))
(define code-insp (current-code-inspector)))