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

macro debugger: fixes for PR 10090

Browse Source 
pass1/pass2 for module-begin tagging vs module body expansion
  reset current syntax on entry to bind-syntaxes

svn: r13993

original commit: e2f588554aa85282a74dffa773954aab6662e5e9
This commit is contained in:
Ryan Culpepper 2009-03-06 21:20:24 +00:00
commit c199055ac7
2 changed files with 47 additions and 27 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
collects/macro-debugger/model/reductions-engine.ss
View File

@ -14,6 +14,14 @@
DEBUG DEBUG
R) R)
(define-syntax-rule (with-syntax1 ([pattern rhs]) . body)
(syntax-case rhs ()
[pattern (let () . body)]
[x (raise-syntax-error 'with-syntax1
(format "failed pattern match against ~s"
'pattern)
#'x)]))
(begin-for-syntax (begin-for-syntax
(expr/c-use-contracts? #f)) (expr/c-use-contracts? #f))
@ -99,12 +107,12 @@
;; Execute expressions for effect ;; Execute expressions for effect
[(R** f v p s ws [#:do expr ...] . more) [(R** f v p s ws [#:do expr ...] . more)
#'(begin #'(begin
(with-syntax ([p f]) (with-syntax1 ([p f])
expr ... (void)) expr ... (void))
(R** f v p s ws . more))] (R** f v p s ws . more))]
[(R** f v p s ws [#:let var expr] . more) [(R** f v p s ws [#:let var expr] . more)
#'(let ([var (with-syntax ([p f]) expr)]) #'(let ([var (with-syntax1 ([p f]) expr)])
(R** f v p s ws . more))] (R** f v p s ws . more))]
[(R** f v p s ws [#:parameterize ((param expr) ...) . clauses] . more) [(R** f v p s ws [#:parameterize ((param expr) ...) . clauses] . more)
@ -116,14 +124,14 @@
;; Change syntax ;; Change syntax
[(R** f v p s ws [#:set-syntax form] . more) [(R** f v p s ws [#:set-syntax form] . more)
#:declare form (expr/c #'syntaxish?) #:declare form (expr/c #'syntaxish?)
#'(let ([f2 (with-syntax ([p f]) form)]) #'(let ([f2 (with-syntax1 ([p f]) form)])
;; FIXME: should (current-pass-hides?) be relevant? ;; FIXME: should (current-pass-hides?) be relevant?
(let ([v2 (if (visibility) f2 v)]) (let ([v2 (if (visibility) f2 v)])
(R** f2 v2 p s ws . more)))] (R** f2 v2 p s ws . more)))]
[(R** f v p s ws [#:expect-syntax expr ds] . more) [(R** f v p s ws [#:expect-syntax expr ds] . more)
#:declare expr (expr/c #'syntax?) #:declare expr (expr/c #'syntax?)
#'(let ([expected (with-syntax ([p f]) expr)]) #'(let ([expected (with-syntax1 ([p f]) expr)])
(STRICT-CHECKS (STRICT-CHECKS
(check-same-stx 'expect-syntax f expected ds)) (check-same-stx 'expect-syntax f expected ds))
(R** f v p s ws . more))] (R** f v p s ws . more))]
@ -140,7 +148,7 @@
#:declare fs (expr/c #'syntaxish?) #:declare fs (expr/c #'syntaxish?)
#:declare type (expr/c #'(or/c step-type? false/c)) #:declare type (expr/c #'(or/c step-type? false/c))
#'(let ([s2 (and (visibility) #'(let ([s2 (and (visibility)
(current-state-with v (with-syntax ([p f]) fs)))] (current-state-with v (with-syntax1 ([p f]) fs)))]
[type-var type]) [type-var type])
(DEBUG (DEBUG
(printf "visibility = ~s\n" (visibility)) (printf "visibility = ~s\n" (visibility))
@ -154,7 +162,7 @@
[(R** f v p s ws [#:walk form2 description] . more) [(R** f v p s ws [#:walk form2 description] . more)
#:declare form2 (expr/c #'syntaxish?) #:declare form2 (expr/c #'syntaxish?)
#'(let ([wfv (with-syntax ([p f]) form2)]) #'(let ([wfv (with-syntax1 ([p f]) form2)])
(R** f v p s ws (R** f v p s ws
[#:left-foot] [#:left-foot]
[#:set-syntax wfv] [#:set-syntax wfv]
@ -165,7 +173,7 @@
#:declare rs (expr/c #'(listof step?)) #:declare rs (expr/c #'(listof step?))
#'(let ([ws2 #'(let ([ws2
(if (visibility) (if (visibility)
(revappend (with-syntax ([p f]) rs) ws) (revappend (with-syntax1 ([p f]) rs) ws)
ws)]) ws)])
(R** f v p s ws2 . more))] (R** f v p s ws2 . more))]
@ -184,10 +192,10 @@
[(R** f v p s ws [#:rename* pattern renames description mark-flag] . more) [(R** f v p s ws [#:rename* pattern renames description mark-flag] . more)
#'(let-values ([(renames-var description-var) #'(let-values ([(renames-var description-var)
(with-syntax ([p f]) (with-syntax1 ([p f])
(values renames description))]) (values renames description))])
(let* ([pre-renames-var (let* ([pre-renames-var
(with-syntax ([p f]) (syntax pattern))] (with-syntax1 ([p f]) (syntax pattern))]
[f2 [f2
((CC pattern f p) renames)] ((CC pattern f p) renames)]
[whole-form-rename? (eq? f pre-renames-var)] [whole-form-rename? (eq? f pre-renames-var)]
@ -221,7 +229,7 @@
[(R** f v p s ws [#:rename/mark pvar from to] . more) [(R** f v p s ws [#:rename/mark pvar from to] . more)
#:declare from (expr/c #'syntaxish?) #:declare from (expr/c #'syntaxish?)
#:declare to (expr/c #'syntaxish?) #:declare to (expr/c #'syntaxish?)
#'(let ([real-from (with-syntax ([p f]) #'pvar)]) #'(let ([real-from (with-syntax1 ([p f]) #'pvar)])
(STRICT-CHECKS (STRICT-CHECKS
(check-same-stx 'rename/mark real-from from)) (check-same-stx 'rename/mark real-from from))
(when (marking-table) (when (marking-table)
@ -231,7 +239,7 @@
[(R** f v p s ws [#:rename/unmark pvar from to] . more) [(R** f v p s ws [#:rename/unmark pvar from to] . more)
#:declare from (expr/c #'syntaxish?) #:declare from (expr/c #'syntaxish?)
#:declare to (expr/c #'syntaxish?) #:declare to (expr/c #'syntaxish?)
#'(let ([real-from (with-syntax ([p f]) #'pvar)]) #'(let ([real-from (with-syntax1 ([p f]) #'pvar)])
(STRICT-CHECKS (STRICT-CHECKS
(check-same-stx 'rename/mark real-from from)) (check-same-stx 'rename/mark real-from from))
(R** f v p s ws [#:rename* pvar to #f 'unmark] . more))] (R** f v p s ws [#:rename* pvar to #f 'unmark] . more))]
@ -240,7 +248,7 @@
[(R** f v p s ws [#:rename/no-step pvar from to] . more) [(R** f v p s ws [#:rename/no-step pvar from to] . more)
#:declare from (expr/c #'syntaxish?) #:declare from (expr/c #'syntaxish?)
#:declare to (expr/c #'syntaxish?) #:declare to (expr/c #'syntaxish?)
#'(let ([real-from (with-syntax ([p f]) #'pvar)]) #'(let ([real-from (with-syntax1 ([p f]) #'pvar)])
(STRICT-CHECKS (STRICT-CHECKS
(check-same-stx 'rename/no-step real-from from)) (check-same-stx 'rename/no-step real-from from))
(R** f v p s ws [#:rename pvar to] . more))] (R** f v p s ws [#:rename pvar to] . more))]
@ -248,20 +256,20 @@
;; Add to definite uses ;; Add to definite uses
[(R** f v p s ws [#:learn ids] . more) [(R** f v p s ws [#:learn ids] . more)
#:declare ids (expr/c #'(listof identifier?)) #:declare ids (expr/c #'(listof identifier?))
#'(begin (learn-definites (with-syntax ([p f]) ids)) #'(begin (learn-definites (with-syntax1 ([p f]) ids))
(R** f v p s ws . more))] (R** f v p s ws . more))]
;; Conditional (pattern changes lost afterwards ...) ;; Conditional (pattern changes lost afterwards ...)
[(R** f v p s ws [#:if test [consequent ...] [alternate ...]] . more) [(R** f v p s ws [#:if test [consequent ...] [alternate ...]] . more)
#'(let ([continue (RP p . more)]) #'(let ([continue (RP p . more)])
(if (with-syntax ([p f]) test) (if (with-syntax1 ([p f]) test)
(R** f v p s ws consequent ... => continue) (R** f v p s ws consequent ... => continue)
(R** f v p s ws alternate ... => continue)))] (R** f v p s ws alternate ... => continue)))]
;; Conditional (pattern changes lost afterwards ...) ;; Conditional (pattern changes lost afterwards ...)
[(R** f v p s ws [#:when test consequent ...] . more) [(R** f v p s ws [#:when test consequent ...] . more)
#'(let ([continue (RP p . more)]) #'(let ([continue (RP p . more)])
(if (with-syntax ([p f]) test) (if (with-syntax1 ([p f]) test)
(R** f v p s ws consequent ... => continue) (R** f v p s ws consequent ... => continue)
(continue f v s ws)))] (continue f v s ws)))]
@ -285,8 +293,9 @@
;; ** Multi-pass reductions ** ;; ** Multi-pass reductions **
;; Pass1 does expansion. ;; Pass1 does expansion.
;; If something should happen regardless of whether hiding occurred in pass1, ;; If something should happen regardless of whether hiding occurred
;; put it before the Pass2 marker (eg, lifting). ;; in pass1 (eg, lifting), put it before the Pass2 marker.
;; Use #:unsafe-bind-visible to access 'v' ;; Use #:unsafe-bind-visible to access 'v'
;; Warning: don't do anything that relies on real 'f' before pass2 ;; Warning: don't do anything that relies on real 'f' before pass2
@ -294,7 +303,8 @@
;; put it after the Pass2 marker (eg, splice, block->letrec). ;; put it after the Pass2 marker (eg, splice, block->letrec).
[(R** f v p s ws [#:pass1] . more) [(R** f v p s ws [#:pass1] . more)
#'(parameterize ((hides-flags (cons (box (not (visibility))) (hides-flags)))) #'(parameterize ((hides-flags
(cons (box (not (visibility))) (hides-flags))))
(DEBUG (printf "** pass1\n")) (DEBUG (printf "** pass1\n"))
(R** f v p s ws . more))] (R** f v p s ws . more))]
@ -335,11 +345,12 @@
(define-syntax (Run stx) (define-syntax (Run stx)
(syntax-case stx () (syntax-case stx ()
;; Implementation of subterm handling for (hole ...) sequences ;; Implementation of subterm handling for (hole ...) sequences
[(Run reducer f v p s ws (hole :::) fills k) [(Run reducer f v p s ws (hole :::) fills-e k)
(and (identifier? #':::) (and (identifier? #':::)
(free-identifier=? #'::: (quote-syntax ...))) (free-identifier=? #'::: (quote-syntax ...)))
#'(let* ([fctx (CC (hole :::) f p)] #'(let* ([fctx (CC (hole :::) f p)]
[init-e1s (with-syntax ([p f]) (syntax->list #'(hole :::)))]) [init-e1s (with-syntax1 ([p f]) (syntax->list #'(hole :::)))]
[fills fills-e])
(DEBUG (DEBUG
(printf "Run (multi, vis=~s)\n" (visibility)) (printf "Run (multi, vis=~s)\n" (visibility))
(printf " f: ~e\n" (stx->datum f)) (printf " f: ~e\n" (stx->datum f))
@ -349,12 +360,12 @@
(print-viable-subterms v)) (print-viable-subterms v))
(if (visibility) (if (visibility)
(let ([vctx (CC (hole :::) v p)] (let ([vctx (CC (hole :::) v p)]
[vsubs (with-syntax ([p v]) (syntax->list #'(hole :::)))]) [vsubs (with-syntax1 ([p v]) (syntax->list #'(hole :::)))])
(run-multiple/visible reducer init-e1s fctx vsubs vctx fills s ws k)) (run-multiple/visible reducer init-e1s fctx vsubs vctx fills s ws k))
(run-multiple/nonvisible reducer init-e1s fctx v fills s ws k)))] (run-multiple/nonvisible reducer init-e1s fctx v fills s ws k)))]
;; Implementation of subterm handling ;; Implementation of subterm handling
[(Run reducer f v p s ws hole fill k) [(Run reducer f v p s ws hole fill k)
#'(let* ([init-e (with-syntax ([p f]) #'hole)] #'(let* ([init-e (with-syntax1 ([p f]) #'hole)]
[fctx (CC hole f p)]) [fctx (CC hole f p)])
(DEBUG (DEBUG
(printf "Run (single, vis=~s)\n" (visibility)) (printf "Run (single, vis=~s)\n" (visibility))
@ -365,7 +376,7 @@
(print-viable-subterms v)) (print-viable-subterms v))
(if (visibility) (if (visibility)
(let ([vctx (CC hole v p)] (let ([vctx (CC hole v p)]
[vsub (with-syntax ([p v]) #'hole)]) [vsub (with-syntax1 ([p v]) #'hole)])
(run-one reducer init-e fctx vsub vctx fill s ws k)) (run-one reducer init-e fctx vsub vctx fill s ws k))
(run-one reducer init-e fctx v values fill s ws k)))])) (run-one reducer init-e fctx v values fill s ws k)))]))
@ -384,7 +395,11 @@
(DEBUG (DEBUG
(printf "run-multiple/visible\n") (printf "run-multiple/visible\n")
(printf " fctx: ~e\n" (stx->datum (fctx (for/list ([dummy init-e1s]) #'HOLE)))) (printf " fctx: ~e\n" (stx->datum (fctx (for/list ([dummy init-e1s]) #'HOLE))))
(printf " vctx: ~e\n" (stx->datum (vctx (for/list ([dummy init-e1s]) #'HOLE))))) (printf " vctx: ~e\n" (stx->datum (vctx (for/list ([dummy init-e1s]) #'HOLE))))
(unless (= (length fills) (length init-e1s))
(printf " fills(~s): ~e\n" (length fills) fills)
(printf " init-e1s: ~s\n" (stx->datum init-e1s))
(printf " vsubs: ~s\n" (stx->datum vsubs))))
(let loop ([fills fills] [prefix null] [vprefix null] [suffix init-e1s] [vsuffix vsubs] [s s] [ws ws]) (let loop ([fills fills] [prefix null] [vprefix null] [suffix init-e1s] [vsuffix vsubs] [s s] [ws ws])
(cond (cond
[(pair? fills) [(pair? fills)

11
collects/macro-debugger/model/reductions.ss
View File

@ -61,7 +61,8 @@
[#:when (not (bound-identifier=? e1 e2)) [#:when (not (bound-identifier=? e1 e2))
[#:walk e2 'resolve-variable]])] [#:walk e2 'resolve-variable]])]
[(Wrap p:module (e1 e2 rs ?1 ?2 tag rename check tag2 ?3 body shift)) [(Wrap p:module (e1 e2 rs ?1 ?2 tag rename check tag2 ?3 body shift))
(R [! ?1] (R ;; [#:hide-check rs] ;; FIXME: test and enable!!!
[! ?1]
[#:pattern (?module ?name ?language . ?body-parts)] [#:pattern (?module ?name ?language . ?body-parts)]
[! ?2] [! ?2]
[#:when tag [#:when tag
@ -69,11 +70,13 @@
[#:walk (list tag) 'tag-module-begin]]] [#:walk (list tag) 'tag-module-begin]]]
[#:pattern (?module ?name ?language ?body)] [#:pattern (?module ?name ?language ?body)]
[#:rename ?body rename] [#:rename ?body rename]
[#:pass1]
[#:when check [#:when check
[Expr ?body check]] [Expr ?body check]]
[#:when tag2 [#:when tag2
[#:in-hole ?body [#:in-hole ?body
[#:walk tag2 'tag-module-begin]]] [#:walk tag2 'tag-module-begin]]]
[#:pass2]
[! ?3] [! ?3]
[Expr ?body body] [Expr ?body body]
[#:pattern ?form] [#:pattern ?form]
@ -533,7 +536,8 @@
(define (BindSyntaxes bindrhs) (define (BindSyntaxes bindrhs)
(match bindrhs (match bindrhs
[(Wrap bind-syntaxes (rhs ?1)) [(Wrap bind-syntaxes (rhs ?1))
(R [#:pattern ?form] (R [#:set-syntax (node-z1 rhs)] ;; set syntax; could be in local-bind
[#:pattern ?form]
[Expr/PhaseUp ?form rhs] [Expr/PhaseUp ?form rhs]
[! ?1])])) [! ?1])]))
@ -570,7 +574,8 @@
[(cons (Wrap mod:lift (head renames stxs)) rest) [(cons (Wrap mod:lift (head renames stxs)) rest)
(R [#:pattern (?firstL . ?rest)] (R [#:pattern (?firstL . ?rest)]
;; renames has form (head-e2 . ?rest) ;; renames has form (head-e2 . ?rest)
;; stxs has form (lifted ...), specifically (last-lifted ... first-lifted) ;; stxs has form (lifted ...),
;; specifically (last-lifted ... first-lifted)
[#:parameterize ((available-lift-stxs (reverse stxs)) [#:parameterize ((available-lift-stxs (reverse stxs))
(visible-lift-stxs null)) (visible-lift-stxs null))
[#:pass1] [#:pass1]