commit 7e0f3cbdcac2221875d487133e1871a053a2f921
parent 8874fe41a07a57becb02a004cab26ece115a7bec
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Thu, 11 Jan 2007 23:16:58 +0000
Macro stepper:
simplified match patterns, eliminated old dollar-sign patterns
added derivs to reductions; prep for jump-to and zoom-in
changed step-note to step-type
svn: r5316
original commit: 9330d96ad7d1b66b5c6d3e1310cc14298d2c7ed1
Diffstat:
5 files changed, 278 insertions(+), 258 deletions(-)
diff --git a/collects/macro-debugger/model/deriv-util.ss b/collects/macro-debugger/model/deriv-util.ss
@@ -7,9 +7,6 @@
AnyQ
IntQ
- $$
- $$I
- $$E
Wrap
lift/wrap
rewrap
@@ -48,74 +45,54 @@
(define-match-expander AnyQ
(syntax-rules ()
[(AnyQ S (var ...))
- (or (struct S (var ...))
- (struct interrupted-wrap (_ (struct S (var ...))))
- (struct error-wrap (_ _ (struct S (var ...)))))]
+ (app unwrap (struct S (var ...)))]
[(AnyQ S (var ...) exni)
- (or (and (struct S (var ...))
- (app (lambda (_) #f) exni))
- (and (struct interrupted-wrap (tag (struct S (var ...))))
- (app (lambda (ew) (cons #f (interrupted-wrap-tag ew))) exni))
- (and (struct error-wrap (exn tag (struct S (var ...))))
- (app (lambda (ew) (cons (error-wrap-exn ew) (error-wrap-tag ew))) exni)))]))
-
+ (and (app unwrap (struct S (var ...)))
+ (app extract-exni exni))]))
+
;; IntQ
;; Matches interrupted wraps and unwrapped structs
(define-match-expander IntQ
(syntax-rules ()
[(IntQ S (var ...))
- (or (struct S (var ...))
- (struct interrupted-wrap (_ (struct S (var ...)))))]
+ (? not-error-wrap? (app unwrap (struct S (var ...))))]
[(IntQ S (var ...) tag)
- (or (and (struct S (var ...))
- (app (lambda (_) #f) tag))
- (struct interrupted-wrap (tag (struct S (var ...)))))]))
-
- ;; $$ match form
- ;; ($$ struct-name (var ...) info)
- ;; If normal instance of struct-name, binds info to #f
- ;; If interrupted-wrapped, binds info to (cons #f symbol/#f)
- ;; If error-wrapped, binds info to (cons exn symbol/#f)
- (define-match-expander $$
- (lambda (stx)
- (syntax-case stx ()
- [($$ S (var ...) info)
- #'(or (and (struct S (var ...))
- (app (lambda (_) #f) info))
- (and (struct interrupted-wrap (tag (struct S (var ...))))
- (app (lambda (ew) (cons #f (interrupted-wrap-tag ew))) info))
- (and (struct error-wrap (exn tag (struct S (var ...))))
- (app (lambda (ew) (cons (error-wrap-exn ew) (error-wrap-tag ew)))
- info)))]
- [($$ S (var ...))
- #'(struct S (var ...))])))
-
- (define-match-expander $$I
- (lambda (stx)
- (syntax-case stx ()
- [($$I S (var ...))
- #'(or (struct interrupted-wrap (tag (struct S (var ...))))
- (struct S (var ...)))]
- [($$I S (var ...) tag)
- #'(or (struct interrupted-wrap (tag (struct S (var ...))))
- (and (app (lambda (_) #f) tag)
- (struct S (var ...))))])))
-
- (define-match-expander $$E
- (lambda (stx)
- (syntax-case stx ()
- [($$E S (var ...))
- #'(or (struct interrupted-wrap (_tag (struct S (var ...))))
- (struct error-wrap (_exn _tag (struct S (var ...))))
- (struct S (var ...)))])))
+ (? not-error-wrap?
+ (app unwrap (struct S (var ...)))
+ (app extract-tag tag))]))
(define-match-expander Wrap
(syntax-rules ()
[(Wrap x)
- (or (struct interrupted-wrap (_tag x))
- (struct error-wrap (_exn _tag x))
- x)]))
+ (app unwrap x)]))
+ (define (unwrap x)
+ (match x
+ [(struct interrupted-wrap (tag inner))
+ inner]
+ [(struct error-wrap (exn tag inner))
+ inner]
+ [else x]))
+
+ (define (extract-exni x)
+ (match x
+ [(struct interrupted-wrap (tag inner))
+ (cons #f tag)]
+ [(struct error-wrap (exn tag inner))
+ (cons exn tag)]
+ [else #f]))
+
+ (define (extract-tag x)
+ (match x
+ [(struct interrupted-wrap (tag inner))
+ tag]
+ [(struct error-wrap (exn tag inner))
+ tag]
+ [else #f]))
+
+ (define (not-error-wrap? x)
+ (not (error-wrap? x)))
+
;; lift/wrap : ('a -> 'b) boolean -> Wrap('a) -> Wrap('b)
(define (lift/wrap f preserve-tag?)
(lambda (x)
@@ -156,16 +133,6 @@
(or (interrupted-wrap? x)
(error-wrap? x)))
-; (define-match-expander $$E
-; (lambda (stx)
-; (syntax-case stx (@)
-; [($$E S (var ...))
-; #'($$ S (var ...) _exni)]
-; [($$E S (var ...) @ tag)
-; #'($$ S (var ...) (cons #f tag))]
-; [($$E S (var ...) @ tag exn)
-; #'($$ S (var ...) (cons exn tag))])))
-
;; Utilities for finding subderivations
;; find-derivs : (deriv -> boolean) (deriv -> boolean) deriv -> (list-of deriv)
diff --git a/collects/macro-debugger/model/reductions-engine.ss b/collects/macro-debugger/model/reductions-engine.ss
@@ -7,14 +7,17 @@
(all-from "steps.ss"))
;; A Context is (syntax -> syntax)
- ;; A BigContext is (list-of (cons Syntaxes Syntax))
- ;; local expansion contexts: pairs of foci, term
+ ;; A BigContext is (list-of (cons Derivation (cons Syntaxes Syntax)))
+ ;; local expansion contexts: deriv, foci, term
;; context: parameter of Context
(define context (make-parameter (lambda (x) x)))
;; big-context: parameter of BigContext
(define big-context (make-parameter null))
+
+ ;; current-derivation : parameter of Derivation
+ (define current-derivation (make-parameter #f))
(define-syntax with-context
(syntax-rules ()
@@ -22,11 +25,18 @@
(let ([E (context)])
(parameterize ([context (lambda (x) (E (f x)))])
. body))]))
+
+ (define-syntax with-derivation
+ (syntax-rules ()
+ [(with-derivation d . body)
+ (parameterize ((current-derivation d)) . body)]))
(define-syntax with-new-local-context
(syntax-rules ()
[(with-new-local-context e . body)
- (parameterize ([big-context (cons (cons (list e) (E e)) (big-context))]
+ (parameterize ([big-context
+ (cons (cons (current-derivation) (cons (list e) (E e)))
+ (big-context))]
[context (lambda (x) x)])
. body)]))
@@ -79,9 +89,9 @@
#'(let-values ([(form2-var foci1-var foci2-var description-var)
(with-syntax ([p f])
(values form2 foci1 foci2 description))])
- (cons (walk-rename/foci/E foci1-var foci2-var
- f form2-var
- description-var)
+ (cons (walk/foci/E foci1-var foci2-var
+ f form2-var
+ description-var)
(R** form2-var p . more)))]
[(R** f p [#:walk form2 description] . more)
#'(let-values ([(form2-var description-var)
@@ -106,7 +116,7 @@
;; If this is the key, then insert the misstep here and stop.
;; This stops processing *within* an error-wrapped prim.
(if (or (eq? key #f) (eq? key (cdr info)))
- (list (make-misstep f (E f) (car info)))
+ (list (stumble f (car info)))
(continue))]
[else
(continue)]))]
@@ -115,16 +125,6 @@
#'(let-values ([(reducer get-e1 get-e2) Generator])
(R** f p [reducer get-e1 get-e2 hole0 fill0] . more))]
-; ;; Expression case
-; [(R** f p [hole0 fill0] . more)
-; #'(R** f p [reductions deriv-e1 deriv-e2 hole0 fill0] . more)]
-; ;; List case
-; [(R** f p [List hole0 fill0] . more)
-; #'(R** f p [list-reductions lderiv-es1 lderiv-es2 hole0 fill0] . more)]
-; ;; Block case
-; [(R** f p [Block hole0 fill0] . more)
-; #'(R** f p [block-reductions bderiv-es1 bderiv-es2 hole0 fill0] . more)]
-
;; Implementation for (hole ...) sequences
[(R** form-var pattern
[f0 get-e1 get-e2 (hole0 :::) fill0s] . more)
@@ -168,33 +168,34 @@
;; -----------------------------------
- ;; walk : syntax(s) syntax(s) [string] -> Reduction
+ ;; walk : syntax(s) syntax(s) StepType -> Reduction
;; Lifts a local step into a term step.
- (define walk
- (case-lambda
- [(e1 e2) (walk e1 e2 #f)]
- [(e1 e2 note) (make-rewrite-step e1 e2 (E e1) (E e2) note (big-context))]))
+ (define (walk e1 e2 type)
+ (make-step (current-derivation) (big-context) type
+ e1 e2 (E e1) (E e2)))
+
+ ;; walk/foci/E : syntax(s) syntax(s) syntax syntax StepType -> Reduction
+ (define (walk/foci/E focus1 focus2 e1 e2 type)
+ (walk/foci focus1 focus2 (E e1) (E e2) type))
+
+ ;; walk/foci : syntax(s) syntax(s) syntax syntax StepType -> Reduction
+ (define (walk/foci focus1 focus2 Ee1 Ee2 type)
+ (make-step (current-derivation) (big-context) type
+ focus1 focus2 Ee1 Ee2))
- ;; walk/foci/E : syntax(s) syntax(s) syntax syntax string -> Reduction
- (define (walk/foci/E focus1 focus2 e1 e2 note)
- (walk/foci focus1 focus2 (E e1) (E e2) note))
-
- ;; walk-rename/foci/E : syntax(s) syntax(s) syntax syntax string -> Reduction
- (define (walk-rename/foci/E focus1 focus2 e1 e2 note)
- (make-rename-step focus1 focus2 (E e1) (E e2) note (big-context)))
-
- ;; walk/foci : syntax(s) syntax(s) syntax syntax string -> Reduction
- (define (walk/foci focus1 focus2 Ee1 Ee2 note)
- (make-rewrite-step focus1 focus2 Ee1 Ee2 note (big-context)))
-
;; stumble : syntax exception -> Reduction
(define (stumble stx exn)
- (make-misstep stx (E stx) exn))
+ (make-misstep (current-derivation) (big-context) 'error
+ stx (E stx) exn))
+
+ ;; stumble/E : syntax(s) syntax exn -> Reduction
+ (define (stumble/E focus Ee1 exn)
+ (make-misstep (current-derivation) (big-context) 'error
+ focus Ee1 exn))
+
;; ------------------------------------
(define (revappend a b)
(cond [(pair? a) (revappend (cdr a) (cons (car a) b))]
[(null? a) b]))
-
-
)
\ No newline at end of file
diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss
@@ -21,22 +21,31 @@
(syntax-id-rules ()
[Block (values block-reductions bderiv-es1 bderiv-es2)]))
+ ;; Syntax
+
+ (define-syntax match/with-derivation
+ (syntax-rules ()
+ [(match/with-derivation d . clauses)
+ (let ([dvar d])
+ (with-derivation dvar
+ (match dvar . clauses)))]))
+
;; Reductions
;; reductions : Derivation -> ReductionSequence
(define (reductions d)
- (match d
+ (match/with-derivation d
;; Primitives
[(struct p:variable (e1 e2 rs))
(if (bound-identifier=? e1 e2)
null
- (list (walk e1 e2 "Resolve variable (remove extra marks)")))]
+ (list (walk e1 e2 'resolve-variable)))]
[(IntQ p:module (e1 e2 rs #f body))
(with-syntax ([(?module name language . BODY) e1])
(let ([ctx (lambda (x) (d->so e1 `(,#'?module ,#'name ,#'language ,x)))]
- [body-e1 (match body [($$ deriv (body-e1 _) _) body-e1])])
- (cons (walk e1 (ctx body-e1) "Tag #%module-begin")
+ [body-e1 (match body [(AnyQ deriv (body-e1 _)) body-e1])])
+ (cons (walk e1 (ctx body-e1) 'tag-module-begin)
(with-context ctx
(reductions body)))))]
[(IntQ p:module (e1 e2 rs #t body))
@@ -106,7 +115,7 @@
[List LDERIV lderiv])])
(if (eq? tagged-stx e1)
tail
- (cons (walk e1 tagged-stx "Tag application") tail)))]
+ (cons (walk e1 tagged-stx 'tag-app) tail)))]
[(AnyQ p:lambda (e1 e2 rs renames body) exni)
(R e1 _
[! exni]
@@ -114,7 +123,7 @@
[#:pattern (?lambda ?formals . ?body)]
[#:rename (syntax/skeleton e1 (?lambda ?formals* . ?body*))
#'?formals #'?formals*
- "Rename formal parameters"]
+ 'rename-lambda]
[Block ?body body])]
[(struct p:case-lambda (e1 e2 rs renames+bodies))
#;
@@ -126,14 +135,14 @@
(syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...))
(syntax->list #'(?formals ...))
(syntax->list #'(?formals* ...))
- "Rename formal parameters"]
+ 'rename-case-lambda]
[Block (?body ...) (map cdr renames+bodies)])
(with-syntax ([(?case-lambda [?formals . ?body] ...) e1]
[((?formals* . ?body*) ...) (map car renames+bodies)])
(let ([mid (syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...))])
(cons (walk/foci/E (syntax->list #'(?formals ...))
(syntax->list #'(?formals* ...))
- e1 mid "Rename formal parameters")
+ e1 mid 'rename-case-lambda)
(R mid (CASE-LAMBDA [FORMALS . BODY] ...)
[Block (BODY ...) (map cdr renames+bodies)]))))]
[(AnyQ p:let-values (e1 e2 rs renames rhss body) exni)
@@ -145,7 +154,7 @@
(syntax/skeleton e1 (?let-values ([?vars* ?rhs*] ...) . ?body*))
(syntax->list #'(?vars ...))
(syntax->list #'(?vars* ...))
- "Rename bound variables"]
+ 'rename-let-values]
[Expr (?rhs ...) rhss]
[Block ?body body])]
[(AnyQ p:letrec-values (e1 e2 rs renames rhss body) exni)
@@ -157,7 +166,7 @@
(syntax/skeleton e1 (?letrec-values ([?vars* ?rhs*] ...) . ?body*))
(syntax->list #'(?vars ...))
(syntax->list #'(?vars* ...))
- "Rename bound variables"]
+ 'rename-letrec-values]
[Expr (?rhs ...) rhss]
[Block ?body body])]
[(AnyQ p:letrec-syntaxes+values
@@ -172,34 +181,34 @@
. ?body*))
(syntax->list #'(?svars ...))
(syntax->list #'(?svars* ...))
- "Rename bound variables"]
+ 'rename-lsv]
[Expr (?srhs ...) srhss]
;; If vrenames is #f, no var bindings to rename
[#:if vrenames
[#:bind (([?vvars** ?vrhs**] ...) . ?body**) vrenames]
[#:rename
(syntax/skeleton e1 (?lsv ([?svars* ?srhs*] ...)
- ([?vars** ?vrhs**] ...)
+ ([?vvars** ?vrhs**] ...)
. ?body**))
(syntax->list #'(?vvars* ...))
(syntax->list #'(?vvars** ...))
- "Rename bound variables"]]
+ 'rename-lsv]]
[Expr (?vrhs ...) vrhss]
[Block ?body body]
=> (lambda (mid)
- (list (walk mid e2 "Remove syntax bindings"))))]
+ (list (walk mid e2 'lsv-remove-syntax))))]
;; The auto-tagged atomic primitives
[(AnyQ p:#%datum (e1 e2 rs tagged-stx) exni)
(append (if (eq? e1 tagged-stx)
null
- (list (walk e1 tagged-stx "Tag datum")))
+ (list (walk e1 tagged-stx 'tag-datum)))
(if exni
(list (stumble tagged-stx (car exni)))
null))]
[(AnyQ p:#%top (e1 e2 rs tagged-stx) exni)
(append (if (eq? e1 tagged-stx)
null
- (list (walk e1 tagged-stx "Tag top-level variable")))
+ (list (walk e1 tagged-stx 'tag-top)))
(if exni
(list (stumble tagged-stx (car exni)))
null))]
@@ -262,7 +271,7 @@
[(IntQ lift-deriv (e1 e2 first lifted-stx second))
(append (reductions first)
- (list (walk (deriv-e2 first) lifted-stx "Capture lifts"))
+ (list (walk (deriv-e2 first) lifted-stx 'capture-lifts))
(reductions second))]
;; Skipped
@@ -277,7 +286,7 @@
(match tx
[(struct transformation (e1 e2 rs me1 me2 locals))
(append (reductions-locals e1 locals)
- (list (walk e1 e2 "Macro transformation")))]
+ (list (walk e1 e2 'macro-step)))]
[(IntW transformation (e1 e2 rs me1 me2 locals) 'locals)
(reductions-locals e1 locals)]
[(ErrW transformation (e1 e2 rs me1 me2 locals) 'bad-transformer exn)
@@ -293,19 +302,19 @@
;; reductions-local : LocalAction -> ReductionSequence
(define (reductions-local local)
- (match local
+ (match/with-derivation local
[(struct local-expansion (e1 e2 me1 me2 deriv))
(reductions deriv)]
[(struct local-lift (expr id))
- (list (walk expr id "Macro lifted expression to top-level"))]
+ (list (walk expr id 'local-lift))]
[(struct local-lift-end (decl))
- (list (walk decl decl "Declaration lifted to end of module"))]
+ (list (walk decl decl 'module-lift))]
[(struct local-bind (deriv))
(reductions deriv)]))
;; list-reductions : ListDerivation -> ReductionSequence
(define (list-reductions ld)
- (match ld
+ (match/with-derivation ld
[(IntQ lderiv (es1 es2 derivs))
(let loop ([derivs derivs] [suffix es1])
(cond [(pair? derivs)
@@ -323,7 +332,7 @@
;; block-reductions : BlockDerivation -> ReductionSequence
(define (block-reductions bd)
- (match bd
+ (match/with-derivation bd
;; If interrupted in pass1, skip pass2
[(IntW bderiv (es1 es2 pass1 trans pass2) 'pass1)
(let-values ([(reductions stxs) (brules-reductions pass1 es1)])
@@ -334,8 +343,8 @@
(append reductions1
(if (eq? trans 'letrec)
(match pass2
- [($$ lderiv (pass2-es1 _ _) _exni)
- (list (walk stxs1 pass2-es1 "Transform block to letrec"))])
+ [(AnyQ lderiv (pass2-es1 _ _))
+ (list (walk stxs1 pass2-es1 'block->letrec))])
null)
(list-reductions pass2)))]
[#f null]))
@@ -343,61 +352,63 @@
;; brules-reductions : (list-of-BRule) syntax-list -> ReductionSequence syntax-list
(define (brules-reductions brules all-stxs)
(let loop ([brules brules] [suffix all-stxs] [prefix null] [rss null])
- (match brules
- [(cons (struct b:expr (renames head)) next)
- (let ([estx (deriv-e2 head)])
- (loop next (stx-cdr suffix) (cons estx prefix)
- (cons (with-context (lambda (x)
- (revappend prefix (cons x (stx-cdr suffix))))
- (reductions head))
- rss)))]
- [(cons (IntW b:expr (renames head) tag) '())
- (loop '() #f #f
- (cons (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
- (reductions head))
- rss))]
- [(cons (struct b:defvals (renames head)) next)
- (let ([head-rs
- (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
- (reductions head))])
- (loop next (stx-cdr suffix) (cons (deriv-e2 head) prefix)
- (cons head-rs rss)))]
- [(cons ($$ b:defstx (renames head rhs) _exni) next)
- (let* ([estx (deriv-e2 head)]
- [estx2 (with-syntax ([(?ds ?vars ?rhs) estx]
- [?rhs* (deriv-e2 rhs)])
- ;;FIXME
- #'(?ds ?vars ?rhs*))])
- (loop next (cdr suffix) (cons estx2 prefix)
- (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
- (cons (with-context (CC (?ds ?vars ?rhs) estx ?rhs)
- (reductions rhs))
- (cons (reductions head)
- rss)))))]
- [(cons (struct b:splice (renames head tail)) next)
- (loop next tail prefix
- (cons (list (walk/foci (deriv-e2 head)
- (stx-take tail
- (- (stx-improper-length tail)
- (stx-improper-length (stx-cdr suffix))))
- (E (revappend prefix
- (cons (deriv-e2 head) (stx-cdr suffix))))
- (E (revappend prefix tail))
- "Splice block-level begin"))
- (cons (with-context (lambda (x)
- (revappend prefix (cons x (stx-cdr suffix))))
- (reductions head))
- rss)))]
- [(cons (struct b:begin (renames head derivs)) next)
- ;; FIXME
- (error 'unimplemented)]
- [(cons (struct error-wrap (exn tag _inner)) '())
- (values (list (make-misstep suffix (E (revappend prefix suffix)) exn))
- (revappend prefix suffix))]
- ['()
- (values (apply append (reverse rss))
- (revappend prefix suffix))])))
-
+ (cond [(pair? brules)
+ (let ([brule0 (car brules)]
+ [next (cdr brules)])
+ (match/with-derivation brule0
+ [(struct b:expr (renames head))
+ (let ([estx (deriv-e2 head)])
+ (loop next (stx-cdr suffix) (cons estx prefix)
+ (cons (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
+ (reductions head))
+ rss)))]
+ [(IntW b:expr (renames head) tag)
+ (loop next #f #f
+ (cons (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
+ (reductions head))
+ rss))]
+ [(struct b:defvals (renames head))
+ (let ([head-rs
+ (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
+ (reductions head))])
+ (loop next (stx-cdr suffix) (cons (deriv-e2 head) prefix)
+ (cons head-rs rss)))]
+ [(AnyQ b:defstx (renames head rhs))
+ (let* ([estx (deriv-e2 head)]
+ [estx2 (with-syntax ([(?ds ?vars ?rhs) estx]
+ [?rhs* (deriv-e2 rhs)])
+ ;;FIXME
+ (datum->syntax-object estx `(,#'?ds ,#'?vars ,#'?rhs*) estx estx))])
+ (loop next (cdr suffix) (cons estx2 prefix)
+ (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
+ (cons (with-context (CC (?ds ?vars ?rhs) estx ?rhs)
+ (reductions rhs))
+ (cons (reductions head)
+ rss)))))]
+ [(struct b:splice (renames head tail))
+ (loop next tail prefix
+ (cons (list (walk/foci (deriv-e2 head)
+ (stx-take tail
+ (- (stx-improper-length tail)
+ (stx-improper-length (stx-cdr suffix))))
+ (E (revappend prefix
+ (cons (deriv-e2 head) (stx-cdr suffix))))
+ (E (revappend prefix tail))
+ 'splice-block))
+ (cons (with-context (lambda (x)
+ (revappend prefix (cons x (stx-cdr suffix))))
+ (reductions head))
+ rss)))]
+ [(struct b:begin (renames head derivs))
+ ;; FIXME
+ (error 'unimplemented)]
+ [(struct error-wrap (exn tag _inner))
+ (values (list (stumble/E suffix (E (revappend prefix suffix)) exn))
+ (revappend prefix suffix))]))]
+ [(null? brules)
+ (values (apply append (reverse rss))
+ (revappend prefix suffix))])))
+
;; mbrules-reductions : MBRules (list-of syntax) -> ReductionSequence
;; The reprocess-on-lift? argument controls the behavior of a mod:lift event.
;; In Pass1, #t; in Pass2, #f.
@@ -408,71 +419,65 @@
(let loop ([mbrules mbrules] [suffix all-stxs] [prefix null])
(define (the-context x)
(revappend prefix (cons x (stx-cdr suffix))))
- ;(printf "** MB loop~n")
- ;(printf " rules: ~s~n" mbrules)
- ;(printf " suffix: ~s~n" suffix)
- ;(printf " prefix: ~s~n" prefix)
- (match mbrules
- [(cons (struct mod:skip ()) next)
- (loop next (stx-cdr suffix) (cons (stx-car suffix) prefix))]
- [(cons (struct mod:cons (head)) next)
- (append (with-context the-context (append (reductions head)))
- (let ([estx (and (deriv? head) (deriv-e2 head))])
- (loop next (stx-cdr suffix) (cons estx prefix))))]
- [(cons (AnyQ mod:prim (head prim)) next)
- (append (with-context the-context
- (append (reductions head)
- (reductions prim)))
- (let ([estx (and (deriv? head) (deriv-e2 head))])
- (loop next (stx-cdr suffix) (cons estx prefix))))]
- [(cons (ErrW mod:splice (head stxs) exn) next)
- (append (with-context the-context (reductions head))
- (list (stumble (deriv-e2 head) exn)))]
- [(cons (struct mod:splice (head stxs)) next)
- ;(printf "suffix is: ~s~n" suffix)
- ;(printf "stxs is: ~s~n" stxs)
- (append
- (with-context the-context (reductions head))
- (let ([suffix-tail (stx-cdr suffix)]
- [head-e2 (deriv-e2 head)])
- (cons (walk/foci head-e2
- (stx-take stxs
- (- (stx-improper-length stxs)
- (stx-improper-length suffix-tail)))
- (E (revappend prefix (cons head-e2 suffix-tail)))
- (E (revappend prefix stxs))
- "Splice module-level begin")
+ (cond [(pair? mbrules)
+ (let ([mbrule0 (car mbrules)]
+ [next (cdr mbrules)])
+ (match/with-derivation mbrule0
+ [(struct mod:skip ())
+ (loop next (stx-cdr suffix) (cons (stx-car suffix) prefix))]
+ [(struct mod:cons (head))
+ (append (with-context the-context (append (reductions head)))
+ (let ([estx (and (deriv? head) (deriv-e2 head))])
+ (loop next (stx-cdr suffix) (cons estx prefix))))]
+ [(AnyQ mod:prim (head prim))
+ (append (with-context the-context
+ (append (reductions head)
+ (reductions prim)))
+ (let ([estx (and (deriv? head) (deriv-e2 head))])
+ (loop next (stx-cdr suffix) (cons estx prefix))))]
+ [(ErrW mod:splice (head stxs) exn)
+ (append (with-context the-context (reductions head))
+ (list (stumble (deriv-e2 head) exn)))]
+ [(struct mod:splice (head stxs))
+ (append
+ (with-context the-context (reductions head))
+ (let ([suffix-tail (stx-cdr suffix)]
+ [head-e2 (deriv-e2 head)])
+ (cons (walk/foci head-e2
+ (stx-take stxs
+ (- (stx-improper-length stxs)
+ (stx-improper-length suffix-tail)))
+ (E (revappend prefix (cons head-e2 suffix-tail)))
+ (E (revappend prefix stxs))
+ 'splice-module)
(loop next stxs prefix))))]
- [(cons (struct mod:lift (head stxs)) next)
- ;(printf "suffix is: ~s~n~n" suffix)
- ;(printf "stxs is: ~s~n" stxs)
- (append
- (with-context the-context (reductions head))
- (let ([suffix-tail (stx-cdr suffix)]
- [head-e2 (deriv-e2 head)])
- (let ([new-suffix (append stxs (cons head-e2 suffix-tail))])
- (cons (walk/foci null
- stxs
- (E (revappend prefix (cons head-e2 suffix-tail)))
- (E (revappend prefix new-suffix))
- "Splice definitions from lifted expressions")
- (loop next
- new-suffix
- prefix)))))]
- [(cons (struct mod:lift-end (tail)) next)
- (append
- (if (pair? tail)
- (list (walk/foci null
- tail
- (E (revappend prefix suffix))
- (E (revappend prefix tail))
- "Splice lifted module declarations"))
- null)
- (loop next tail prefix))]
- ['()
- (set! final-stxs (reverse prefix))
- null]))])
+ [(struct mod:lift (head stxs))
+ (append
+ (with-context the-context (reductions head))
+ (let ([suffix-tail (stx-cdr suffix)]
+ [head-e2 (deriv-e2 head)])
+ (let ([new-suffix (append stxs (cons head-e2 suffix-tail))])
+ (cons (walk/foci null
+ stxs
+ (E (revappend prefix (cons head-e2 suffix-tail)))
+ (E (revappend prefix new-suffix))
+ 'splice-lifts)
+ (loop next
+ new-suffix
+ prefix)))))]
+ [(struct mod:lift-end (tail))
+ (append
+ (if (pair? tail)
+ (list (walk/foci null
+ tail
+ (E (revappend prefix suffix))
+ (E (revappend prefix tail))
+ 'splice-module-lifts))
+ null)
+ (loop next tail prefix))]))]
+ [(null? mbrules)
+ (set! final-stxs (reverse prefix))
+ null]))])
(values reductions final-stxs)))
-
)
diff --git a/collects/macro-debugger/model/steps.ss b/collects/macro-debugger/model/steps.ss
@@ -3,14 +3,61 @@
(provide (all-defined))
;; A ReductionSequence is a (list-of Reduction)
+
+ ;; A ProtoStep is (make-protostep Derivation BigContext StepType)
;; A Reduction is one of
- ;; - (make-step Syntaxes Syntaxes Syntax Syntax BigContext)
- ;; - (make-misstep Syntax Syntax Exception)
- (define-struct step (redex contractum e1 e2 note lctx) #f)
- (define-struct misstep (redex e1 exn) #f)
+ ;; - (make-step ... Syntaxes Syntaxes Syntax Syntax)
+ ;; - (make-misstep ... Syntax Syntax Exception)
+
+ (define-struct protostep (deriv lctx type) #f)
+
+ (define-struct (step protostep) (redex contractum e1 e2) #f)
+ (define-struct (misstep protostep) (redex e1 exn) #f)
+
+ ;; A StepType is a simple in the following alist.
+
+ (define step-type-meanings
+ '((macro-step . "Macro transformation")
+
+ (rename-lambda . "Rename formal parameters")
+ (rename-case-lambda . "Rename formal parameters")
+ (rename-let-values . "Rename bound variables")
+ (rename-letrec-values . "Rename bound variables")
+ (rename-lsv . "Rename bound variables")
+ (lsv-remove-syntax . "Remove syntax bindings")
+
+ (resolve-variable . "Resolve variable (remove extra marks)")
+ (tag-module-begin . "Tag #%module-begin")
+ (tag-app . "Tag application")
+ (tag-datum . "Tag datum")
+ (tag-top . "Tag top-level variable")
+ (capture-lifts . "Capture lifts")
+
+ (local-lift . "Macro lifted expression to top-level")
+ (module-lift . "Macro lifted declaration to end of module")
+ (block->letrec . "Transform block to letrec")
+ (splice-block . "Splice block-level begin")
+ (splice-module . "Splice module-level begin")
+ (splice-lifts . "Splice definitions from lifted expressions")
+ (splice-module-lifts . "Splice lifted module declarations")
+
+ (error . "Error")))
+
+ (define (step-type->string x)
+ (cond [(assq x step-type-meanings) => cdr]
+ [(string? x) x]
+ [else (error 'step-type->string "not a step type: ~s" x)]))
+
+ (define (rename-step? x)
+ (memq (protostep-type x)
+ '(rename-lambda
+ rename-case-lambda
+ rename-let-values
+ rename-letrec-values
+ rename-lsv)))
- (define-struct (rewrite-step step) () #f)
- (define-struct (rename-step step) () #f)
+ (define (rewrite-step? x)
+ (and (step? x) (not (rename-step? x))))
)
diff --git a/collects/macro-debugger/stepper-text.ss b/collects/macro-debugger/stepper-text.ss
@@ -62,7 +62,7 @@
(define (show-step step partition)
(cond [(step? step)
- (display (step-note step))
+ (display (step-type->string (protostep-type step)))
(newline)
(show-term (step-e1 step) partition)
(display " ==>")
@@ -73,7 +73,7 @@
(display (exn-message (misstep-exn step)))
(newline)
(show-term (misstep-e1 step) partition)]))
-
+
(define (show-term stx partition)
(define-values (datum flat=>stx stx=>flat)
(table stx partition 0 'always))
