From 9330d96ad7d1b66b5c6d3e1310cc14298d2c7ed1 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 11 Jan 2007 23:16:58 +0000 Subject: [PATCH] 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 --- collects/macro-debugger/model/deriv-util.ss | 105 +++---- collects/macro-debugger/model/hide.ss | 13 +- .../macro-debugger/model/reductions-engine.ss | 75 ++--- collects/macro-debugger/model/reductions.ss | 293 +++++++++--------- collects/macro-debugger/model/steps.ss | 59 +++- collects/macro-debugger/stepper-text.ss | 4 +- collects/macro-debugger/view/gui.ss | 98 +++--- 7 files changed, 323 insertions(+), 324 deletions(-) diff --git a/collects/macro-debugger/model/deriv-util.ss b/collects/macro-debugger/model/deriv-util.ss index 40729edc68..35e9e9ab2e 100644 --- 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/hide.ss b/collects/macro-debugger/model/hide.ss index ab82cb8fa0..af0666b4c9 100644 --- a/collects/macro-debugger/model/hide.ss +++ b/collects/macro-debugger/model/hide.ss @@ -852,14 +852,9 @@ ;; show-mrule? : MRule -> boolean (define (show-transformation? tx) (match tx - [($$ transformation (e1 e2 rs me1 me2 locals)) - (let ([rs (reverse rs)]) - (and (pair? rs) (show-macro? (car rs))))] - [($$ interrupted-wrap (tag inner)) - (show-transformation? inner)] - [($$ error-wrap (exn tag inner)) - (show-transformation? inner)])) - + [(AnyQ transformation (e1 e2 rs me1 me2 locals)) + (ormap show-macro? rs)])) + (define (map/2values f items) (if (null? items) (values null null) @@ -983,7 +978,7 @@ (decompose-letrec letrec-deriv)])] [(list) (match pass2 - [($$ lderiv (_ _ derivs) _) + [(AnyQ lderiv (_ _ derivs)) (values null null derivs)] [#f (values null null null)])])] diff --git a/collects/macro-debugger/model/reductions-engine.ss b/collects/macro-debugger/model/reductions-engine.ss index 9ae287b12c..fd6dd93808 100644 --- 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 index 4f550d1013..673987c365 100644 --- 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 index a8e3a3bb7d..b10d204b5c 100644 --- 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-struct (rewrite-step step) () #f) - (define-struct (rename-step step) () #f) + (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 (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 index acef02d720..e712721532 100644 --- 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)) diff --git a/collects/macro-debugger/view/gui.ss b/collects/macro-debugger/view/gui.ss index 74286cfbdc..64ddd60ef7 100644 --- a/collects/macro-debugger/view/gui.ss +++ b/collects/macro-debugger/view/gui.ss @@ -32,9 +32,9 @@ ;; Struct for one-by-one stepping - (define-struct prestep (redex e1 lctx)) - (define-struct poststep (contractum e2 note lctx)) - + (define-struct (prestep protostep) (redex e1)) + (define-struct (poststep protostep) (contractum e2)) + ;; Macro Stepper (define view@ @@ -210,9 +210,6 @@ ;; steps : cursor (define steps #f) - ;; zoomed? : boolean - (define zoomed? #f) - (define warnings-frame #f) (define/public (add-deriv d) @@ -331,17 +328,6 @@ (set! synth-deriv #f)) (refresh)) - (define/private (navigate-zoom-in) - (set! zoomed? #t) - (update)) - - (define/private (navigate-zoom-out) - (set! zoomed? #f) - (update)) - - (define/private (navigate-skip-to) - '...) - (define/private (insert-step-separator text) (send sbview add-text "\n ") (send sbview add-text @@ -371,7 +357,7 @@ (update) (send text scroll-to-position (unbox start-box) #f (unbox end-box))) - (define (update:show-prefix) + (define/private (update:show-prefix) ;; Show the final terms from the cached synth'd derivs (for-each (lambda (d+sd) (let ([e2 (lift/deriv-e2 (cdr d+sd))]) @@ -380,7 +366,7 @@ (send sbview add-text "Error\n")))) (reverse derivs-prefix))) - (define (update:show-current-step) + (define/private (update:show-current-step) (when steps (let ([step (cursor:current steps)]) (cond [(step? step) @@ -394,45 +380,50 @@ [(not step) (update:show-final)])))) - (define (update:show-lctx lctx) + (define/private (update:show-lctx lctx) (when (pair? lctx) (for-each (lambda (bc) (send sbview add-text "While executing macro transformer in:\n") - (insert-syntax/redex (cdr bc) (car bc))) + (insert-syntax/redex (cddr bc) (cadr bc))) lctx) (send sbview add-text "\n"))) - (define (update:show-step step) - (unless zoomed? - (update:show-lctx (step-lctx step)) - (insert-syntax/redex (step-e1 step) (foci (step-redex step))) - (insert-step-separator (step-note step)) - (insert-syntax/contractum (step-e2 step) (foci (step-contractum step)))) - (when zoomed? - (for-each (lambda (s) (insert-syntax s)) (foci (step-redex step))) - (insert-step-separator (step-note step)) - (for-each (lambda (s) (insert-syntax s)) (foci (step-contractum step))))) + (define/private (update:show-protostep step) + (update:show-lctx (protostep-lctx step))) - (define (update:show-prestep step) - (update:show-lctx (prestep-lctx step)) - (insert-step-separator/small "Find redex") + (define/private (update:separator step) + (insert-step-separator (step-type->string (protostep-type step)))) + + (define/private (update:separator/small step) + (insert-step-separator/small (step-type->string (protostep-type step)))) + + (define/private (update:show-step step) + (update:show-protostep step) + (insert-syntax/redex (step-e1 step) (foci (step-redex step))) + (update:separator step) + (insert-syntax/contractum (step-e2 step) (foci (step-contractum step)))) + + (define/private (update:show-prestep step) + (update:show-protostep step) + (update:separator/small step) (insert-syntax/redex (prestep-e1 step) (foci (prestep-redex step)))) - (define (update:show-poststep step) - (update:show-lctx (poststep-lctx step)) - (insert-step-separator/small (poststep-note step)) + (define/private (update:show-poststep step) + (update:show-protostep step) + (update:separator/small step) (insert-syntax/contractum (poststep-e2 step) (foci (poststep-contractum step)))) - (define (update:show-misstep step) + (define/private (update:show-misstep step) + (update:show-protostep step) (insert-syntax/redex (misstep-e1 step) (foci (misstep-redex step))) - (insert-step-separator "Error") + (update:separator step) (send sbview add-text (exn-message (misstep-exn step))) (send sbview add-text "\n") (when (exn:fail:syntax? (misstep-exn step)) (for-each (lambda (e) (send sbview add-syntax e)) (exn:fail:syntax-exprs (misstep-exn step))))) - (define (update:show-final) + (define/private (update:show-final) (let ([result (lift/deriv-e2 synth-deriv)]) (when result (send sbview add-text "Expansion finished\n") @@ -440,7 +431,7 @@ (unless result (send sbview add-text "Error\n")))) - (define (update:show-suffix) + (define/private (update:show-suffix) (when (pair? derivs) (for-each (lambda (suffix-deriv) (send sbview add-syntax (lift/deriv-e1 suffix-deriv))) @@ -454,7 +445,7 @@ (send text begin-edit-sequence) (send sbview erase-all) - (unless zoomed? (update:show-prefix)) + (update:show-prefix) (send sbview add-separator) (set! position-of-interest (send text last-position)) (update:show-current-step) @@ -492,15 +483,8 @@ (send nav:end enable (and steps (cursor:can-move-next? steps))) (send nav:up enable (and (pair? derivs-prefix))) (send nav:down enable - (and (pair? derivs))) - #; - (send nav:zoom-in enable - (and (not zoomed?) steps (step? (cursor:current steps)))) - #; - (send nav:zoom-out enable zoomed?) - #; - (send nav:jump-to enable #f)) - + (and (pair? derivs)))) + ;; -- ;; refresh/resynth : -> void @@ -584,13 +568,13 @@ (define/private (reduce:one-by-one rs) (let loop ([rs rs]) (match rs - [(cons (struct step (redex contractum e1 e2 note lctx)) rs) - (list* (make-prestep redex e1 lctx) - (make-poststep contractum e2 note lctx) + [(cons (struct step (d l t redex contractum e1 e2)) rs) + (list* (make-prestep d l "Find redex" redex e1) + (make-poststep d l t contractum e2) (loop rs))] - [(cons (struct misstep (redex e1 exn)) rs) - (list* (make-prestep redex e1 null) - (make-misstep redex e1 exn) + [(cons (struct misstep (d l t redex e1 exn)) rs) + (list* (make-prestep d l "Find redex" redex e1) + (make-misstep d l t redex e1 exn) (loop rs))] ['() null])))