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

Macro stepper:

Browse Source 
improved interaction of hiding and lifting (outside of modules, mostly)
  only mzscheme's top-interaction is stripped off automatically now

svn: r5754

original commit: 64f062f5a5292333b79669b4e2dfcc4928e98b0e
This commit is contained in:
Ryan Culpepper 2007-03-08 03:20:15 +00:00
parent 63ee789eb9
commit b272f333d6
3 changed files with 27 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/macro-debugger/model/deriv-parser.ss
View File

@ -157,7 +157,7 @@
[(enter-local local-pre (? EE) local-post exit-local) [(enter-local local-pre (? EE) local-post exit-local)
(make-local-expansion $1 $5 $2 $4 $3)] (make-local-expansion $1 $5 $2 $4 $3)]
[(lift) [(lift)
(make-local-lift (car $1) (cdr $1))] (make-local-lift (cdr $1) (car $1))]
[(lift-statement) [(lift-statement)
(make-local-lift-end $1)] (make-local-lift-end $1)]
[(phase-up (? EE/LetLifts)) [(phase-up (? EE/LetLifts))

4
collects/macro-debugger/model/deriv-util.ss
View File

@ -173,7 +173,7 @@
[(AnyQ mrule (_ _ tx next)) [(AnyQ mrule (_ _ tx next))
(join (loop tx) (loop next))] (join (loop tx) (loop next))]
[(AnyQ lift-deriv (_ _ first lift second)) [(AnyQ lift-deriv (_ _ first lift second))
(join (loop first) (loop lift) (loop second))] (join (loop first) (loop second))]
[(AnyQ transformation (_ _ _ _ _ locals _)) [(AnyQ transformation (_ _ _ _ _ locals _))
(loops locals)] (loops locals)]
[(struct local-expansion (_ _ _ _ deriv)) [(struct local-expansion (_ _ _ _ deriv))
@ -259,8 +259,8 @@
(pred e1)] (pred e1)]
[_ #f]) [_ #f])
(match-lambda (match-lambda
;; FIXME: Why?
[(AnyQ p:module (_ _ _ _ _)) #t] [(AnyQ p:module (_ _ _ _ _)) #t]
[(AnyQ lift-deriv (_ _ _ _ _)) #t]
[_ #f]) [_ #f])
d)) d))

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

@ -37,13 +37,13 @@
(define (reductions d) (define (reductions d)
(parameterize ((current-definites null) (parameterize ((current-definites null)
(current-frontier null)) (current-frontier null))
(add-frontier (list (lift/deriv-e1 d))) (when d (add-frontier (list (lift/deriv-e1 d))))
(reductions* d))) (reductions* d)))
(define (reductions+definites d) (define (reductions+definites d)
(parameterize ((current-definites null) (parameterize ((current-definites null)
(current-frontier null)) (current-frontier null))
(add-frontier (list (lift/deriv-e1 d))) (when d (add-frontier (list (lift/deriv-e1 d))))
(let ([rs (reductions* d)]) (let ([rs (reductions* d)])
(values rs (current-definites))))) (values rs (current-definites)))))
@ -129,13 +129,13 @@
(R e1 (R e1
[! exni] [! exni]
[#:pattern (?begin . LDERIV)] [#:pattern (?begin . LDERIV)]
[#:frontier (stx->list #'LDERIV)] [#:frontier (stx->list* #'LDERIV)]
[List LDERIV lderiv])] [List LDERIV lderiv])]
[(AnyQ p:begin0 (e1 e2 rs first lderiv) exni) [(AnyQ p:begin0 (e1 e2 rs first lderiv) exni)
(R e1 (R e1
[! exni] [! exni]
[#:pattern (?begin0 FIRST . LDERIV)] [#:pattern (?begin0 FIRST . LDERIV)]
[#:frontier (cons #'FIRST (stx->list #'LDERIV))] [#:frontier (cons #'FIRST (stx->list* #'LDERIV))]
[Expr FIRST first] [Expr FIRST first]
[List LDERIV lderiv])] [List LDERIV lderiv])]
[(AnyQ p:#%app (e1 e2 rs tagged-stx lderiv) exni) [(AnyQ p:#%app (e1 e2 rs tagged-stx lderiv) exni)
@ -143,7 +143,7 @@
(R tagged-stx (R tagged-stx
[! exni] [! exni]
[#:pattern (?#%app . LDERIV)] [#:pattern (?#%app . LDERIV)]
[#:frontier (stx->list #'LDERIV)] [#:frontier (stx->list* #'LDERIV)]
[List LDERIV lderiv])]) [List LDERIV lderiv])])
(if (eq? tagged-stx e1) (if (eq? tagged-stx e1)
tail tail
@ -153,7 +153,7 @@
[! exni] [! exni]
[#:bind (?formals* . ?body*) renames] [#:bind (?formals* . ?body*) renames]
[#:pattern (?lambda ?formals . ?body)] [#:pattern (?lambda ?formals . ?body)]
[#:frontier (stx->list #'?body)] [#:frontier (stx->list* #'?body)]
[#:rename (syntax/skeleton e1 (?lambda ?formals* . ?body*)) [#:rename (syntax/skeleton e1 (?lambda ?formals* . ?body*))
#'?formals #'?formals* #'?formals #'?formals*
'rename-lambda] 'rename-lambda]
@ -173,7 +173,7 @@
[Block (?body ...) (map cdr renames+bodies)]) [Block (?body ...) (map cdr renames+bodies)])
(with-syntax ([(?case-lambda [?formals . ?body] ...) e1] (with-syntax ([(?case-lambda [?formals . ?body] ...) e1]
[((?formals* . ?body*) ...) (map car renames+bodies)]) [((?formals* . ?body*) ...) (map car renames+bodies)])
(add-frontier (apply append (map stx->list (syntax->list #'(?body ...))))) (add-frontier (apply append (map stx->list* (syntax->list #'(?body ...)))))
(let ([mid (syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...))]) (let ([mid (syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...))])
(rename-frontier #'(?formals ...) #'(?formals* ...)) (rename-frontier #'(?formals ...) #'(?formals* ...))
(cons (walk/foci (syntax->list #'(?formals ...)) (cons (walk/foci (syntax->list #'(?formals ...))
@ -187,7 +187,7 @@
(R e1 (R e1
[! exni] [! exni]
[#:pattern (?let-values ([?vars ?rhs] ...) . ?body)] [#:pattern (?let-values ([?vars ?rhs] ...) . ?body)]
[#:frontier (append (syntax->list #'(?rhs ...)) (stx->list #'?body))] [#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))]
[#:bind (([?vars* ?rhs*] ...) . ?body*) renames] [#:bind (([?vars* ?rhs*] ...) . ?body*) renames]
[#:rename [#:rename
(syntax/skeleton e1 (?let-values ([?vars* ?rhs*] ...) . ?body*)) (syntax/skeleton e1 (?let-values ([?vars* ?rhs*] ...) . ?body*))
@ -200,7 +200,7 @@
(R e1 (R e1
[! exni] [! exni]
[#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)] [#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)]
[#:frontier (append (syntax->list #'(?rhs ...)) (stx->list #'?body))] [#:frontier (append (syntax->list #'(?rhs ...)) (stx->list* #'?body))]
[#:bind (([?vars* ?rhs*] ...) . ?body*) renames] [#:bind (([?vars* ?rhs*] ...) . ?body*) renames]
[#:rename [#:rename
(syntax/skeleton e1 (?letrec-values ([?vars* ?rhs*] ...) . ?body*)) (syntax/skeleton e1 (?letrec-values ([?vars* ?rhs*] ...) . ?body*))
@ -216,7 +216,7 @@
[#:pattern (?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body)] [#:pattern (?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body)]
[#:frontier (append (syntax->list #'(?srhs ...)) [#:frontier (append (syntax->list #'(?srhs ...))
(syntax->list #'(?vrhs ...)) (syntax->list #'(?vrhs ...))
(stx->list #'?body))] (stx->list* #'?body))]
[#:bind (([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...) . ?body*) srenames] [#:bind (([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...) . ?body*) srenames]
[#:rename [#:rename
(syntax/skeleton e1 (syntax/skeleton e1
@ -338,7 +338,7 @@
(blaze-frontier e1) (blaze-frontier e1)
;;(printf "frontier for mrule: ~s~n" (current-frontier)) ;;(printf "frontier for mrule: ~s~n" (current-frontier))
(append (reductions-transformation transformation) (append (reductions-transformation transformation)
(begin (add-frontier (list (lift/deriv-e1 next))) (begin (when next (add-frontier (list (lift/deriv-e1 next))))
(reductions* next)))] (reductions* next)))]
;; Lifts ;; Lifts
@ -427,7 +427,7 @@
[(AnyQ lderiv (pass2-es1 _ _)) [(AnyQ lderiv (pass2-es1 _ _))
(list (walk stxs1 pass2-es1 'block->letrec))]) (list (walk stxs1 pass2-es1 'block->letrec))])
null) null)
(begin (add-frontier (stx->list (lift/lderiv-es1 pass2))) (begin (add-frontier (stx->list* (lift/lderiv-es1 pass2)))
(list-reductions pass2))))] (list-reductions pass2))))]
[#f null])) [#f null]))
@ -591,4 +591,15 @@
null]))]) null]))])
(values reductions final-stxs))) (values reductions final-stxs)))
(define (stx->list* stx)
(cond [(pair? stx)
(cons (car stx) (stx->list* (cdr stx)))]
[(null? stx)
null]
[(syntax? stx)
(let ([x (syntax-e stx)])
(if (pair? x)
(cons (car x) (stx->list* (cdr x)))
(list stx)))]
[else null]))
) )