commit b272f333d65a6fc41854be7a337220eba908ee50
parent 63ee789eb9a9c68fa0cf87092556671e3be8690d
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Thu, 8 Mar 2007 03:20:15 +0000
Macro stepper:
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
Diffstat:
3 files changed, 27 insertions(+), 16 deletions(-)
diff --git a/collects/macro-debugger/model/deriv-parser.ss b/collects/macro-debugger/model/deriv-parser.ss
@@ -157,7 +157,7 @@
[(enter-local local-pre (? EE) local-post exit-local)
(make-local-expansion $1 $5 $2 $4 $3)]
[(lift)
- (make-local-lift (car $1) (cdr $1))]
+ (make-local-lift (cdr $1) (car $1))]
[(lift-statement)
(make-local-lift-end $1)]
[(phase-up (? EE/LetLifts))
diff --git a/collects/macro-debugger/model/deriv-util.ss b/collects/macro-debugger/model/deriv-util.ss
@@ -173,7 +173,7 @@
[(AnyQ mrule (_ _ tx next))
(join (loop tx) (loop next))]
[(AnyQ lift-deriv (_ _ first lift second))
- (join (loop first) (loop lift) (loop second))]
+ (join (loop first) (loop second))]
[(AnyQ transformation (_ _ _ _ _ locals _))
(loops locals)]
[(struct local-expansion (_ _ _ _ deriv))
@@ -259,8 +259,8 @@
(pred e1)]
[_ #f])
(match-lambda
+ ;; FIXME: Why?
[(AnyQ p:module (_ _ _ _ _)) #t]
- [(AnyQ lift-deriv (_ _ _ _ _)) #t]
[_ #f])
d))
diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss
@@ -37,13 +37,13 @@
(define (reductions d)
(parameterize ((current-definites null)
(current-frontier null))
- (add-frontier (list (lift/deriv-e1 d)))
+ (when d (add-frontier (list (lift/deriv-e1 d))))
(reductions* d)))
(define (reductions+definites d)
(parameterize ((current-definites null)
(current-frontier null))
- (add-frontier (list (lift/deriv-e1 d)))
+ (when d (add-frontier (list (lift/deriv-e1 d))))
(let ([rs (reductions* d)])
(values rs (current-definites)))))
@@ -129,13 +129,13 @@
(R e1
[! exni]
[#:pattern (?begin . LDERIV)]
- [#:frontier (stx->list #'LDERIV)]
+ [#:frontier (stx->list* #'LDERIV)]
[List LDERIV lderiv])]
[(AnyQ p:begin0 (e1 e2 rs first lderiv) exni)
(R e1
[! exni]
[#:pattern (?begin0 FIRST . LDERIV)]
- [#:frontier (cons #'FIRST (stx->list #'LDERIV))]
+ [#:frontier (cons #'FIRST (stx->list* #'LDERIV))]
[Expr FIRST first]
[List LDERIV lderiv])]
[(AnyQ p:#%app (e1 e2 rs tagged-stx lderiv) exni)
@@ -143,7 +143,7 @@
(R tagged-stx
[! exni]
[#:pattern (?#%app . LDERIV)]
- [#:frontier (stx->list #'LDERIV)]
+ [#:frontier (stx->list* #'LDERIV)]
[List LDERIV lderiv])])
(if (eq? tagged-stx e1)
tail
@@ -153,7 +153,7 @@
[! exni]
[#:bind (?formals* . ?body*) renames]
[#:pattern (?lambda ?formals . ?body)]
- [#:frontier (stx->list #'?body)]
+ [#:frontier (stx->list* #'?body)]
[#:rename (syntax/skeleton e1 (?lambda ?formals* . ?body*))
#'?formals #'?formals*
'rename-lambda]
@@ -173,7 +173,7 @@
[Block (?body ...) (map cdr renames+bodies)])
(with-syntax ([(?case-lambda [?formals . ?body] ...) e1]
[((?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*] ...))])
(rename-frontier #'(?formals ...) #'(?formals* ...))
(cons (walk/foci (syntax->list #'(?formals ...))
@@ -187,7 +187,7 @@
(R e1
[! exni]
[#: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]
[#:rename
(syntax/skeleton e1 (?let-values ([?vars* ?rhs*] ...) . ?body*))
@@ -200,7 +200,7 @@
(R e1
[! exni]
[#: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]
[#:rename
(syntax/skeleton e1 (?letrec-values ([?vars* ?rhs*] ...) . ?body*))
@@ -216,7 +216,7 @@
[#:pattern (?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body)]
[#:frontier (append (syntax->list #'(?srhs ...))
(syntax->list #'(?vrhs ...))
- (stx->list #'?body))]
+ (stx->list* #'?body))]
[#:bind (([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...) . ?body*) srenames]
[#:rename
(syntax/skeleton e1
@@ -338,7 +338,7 @@
(blaze-frontier e1)
;;(printf "frontier for mrule: ~s~n" (current-frontier))
(append (reductions-transformation transformation)
- (begin (add-frontier (list (lift/deriv-e1 next)))
+ (begin (when next (add-frontier (list (lift/deriv-e1 next))))
(reductions* next)))]
;; Lifts
@@ -427,7 +427,7 @@
[(AnyQ lderiv (pass2-es1 _ _))
(list (walk stxs1 pass2-es1 'block->letrec))])
null)
- (begin (add-frontier (stx->list (lift/lderiv-es1 pass2)))
+ (begin (add-frontier (stx->list* (lift/lderiv-es1 pass2)))
(list-reductions pass2))))]
[#f null]))
@@ -590,5 +590,16 @@
(set! final-stxs (reverse prefix))
null]))])
(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]))
)
