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

Macro stepper:

Browse Source 
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
This commit is contained in:
Ryan Culpepper 2007-01-11 23:16:58 +00:00
parent 26a4bca1b6
commit 9330d96ad7
7 changed files with 323 additions and 324 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -7,9 +7,6 @@
AnyQ AnyQ
IntQ IntQ
$$
$$I
$$E
Wrap Wrap
lift/wrap lift/wrap
rewrap rewrap
@ -48,74 +45,54 @@
(define-match-expander AnyQ (define-match-expander AnyQ
(syntax-rules () (syntax-rules ()
[(AnyQ S (var ...)) [(AnyQ S (var ...))
(or (struct S (var ...)) (app unwrap (struct S (var ...)))]
(struct interrupted-wrap (_ (struct S (var ...))))
(struct error-wrap (_ _ (struct S (var ...)))))]
[(AnyQ S (var ...) exni) [(AnyQ S (var ...) exni)
(or (and (struct S (var ...)) (and (app unwrap (struct S (var ...)))
(app (lambda (_) #f) exni)) (app extract-exni 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)))]))
;; IntQ ;; IntQ
;; Matches interrupted wraps and unwrapped structs ;; Matches interrupted wraps and unwrapped structs
(define-match-expander IntQ (define-match-expander IntQ
(syntax-rules () (syntax-rules ()
[(IntQ S (var ...)) [(IntQ S (var ...))
(or (struct S (var ...)) (? not-error-wrap? (app unwrap (struct S (var ...))))]
(struct interrupted-wrap (_ (struct S (var ...)))))]
[(IntQ S (var ...) tag) [(IntQ S (var ...) tag)
(or (and (struct S (var ...)) (? not-error-wrap?
(app (lambda (_) #f) tag)) (app unwrap (struct S (var ...)))
(struct interrupted-wrap (tag (struct S (var ...)))))])) (app extract-tag tag))]))
;; $$ 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 ...)))])))
(define-match-expander Wrap (define-match-expander Wrap
(syntax-rules () (syntax-rules ()
[(Wrap x) [(Wrap x)
(or (struct interrupted-wrap (_tag x)) (app unwrap x)]))
(struct error-wrap (_exn _tag x))
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) ;; lift/wrap : ('a -> 'b) boolean -> Wrap('a) -> Wrap('b)
(define (lift/wrap f preserve-tag?) (define (lift/wrap f preserve-tag?)
(lambda (x) (lambda (x)
@ -156,16 +133,6 @@
(or (interrupted-wrap? x) (or (interrupted-wrap? x)
(error-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 ;; Utilities for finding subderivations
;; find-derivs : (deriv -> boolean) (deriv -> boolean) deriv -> (list-of deriv) ;; find-derivs : (deriv -> boolean) (deriv -> boolean) deriv -> (list-of deriv)

13
collects/macro-debugger/model/hide.ss
View File

@ -852,14 +852,9 @@
;; show-mrule? : MRule -> boolean ;; show-mrule? : MRule -> boolean
(define (show-transformation? tx) (define (show-transformation? tx)
(match tx (match tx
[($$ transformation (e1 e2 rs me1 me2 locals)) [(AnyQ transformation (e1 e2 rs me1 me2 locals))
(let ([rs (reverse rs)]) (ormap show-macro? rs)]))
(and (pair? rs) (show-macro? (car rs))))]
[($$ interrupted-wrap (tag inner))
(show-transformation? inner)]
[($$ error-wrap (exn tag inner))
(show-transformation? inner)]))
(define (map/2values f items) (define (map/2values f items)
(if (null? items) (if (null? items)
(values null null) (values null null)
@ -983,7 +978,7 @@
(decompose-letrec letrec-deriv)])] (decompose-letrec letrec-deriv)])]
[(list) [(list)
(match pass2 (match pass2
[($$ lderiv (_ _ derivs) _) [(AnyQ lderiv (_ _ derivs))
(values null null derivs)] (values null null derivs)]
[#f [#f
(values null null null)])])] (values null null null)])])]

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

@ -7,14 +7,17 @@
(all-from "steps.ss")) (all-from "steps.ss"))
;; A Context is (syntax -> syntax) ;; A Context is (syntax -> syntax)
;; A BigContext is (list-of (cons Syntaxes Syntax)) ;; A BigContext is (list-of (cons Derivation (cons Syntaxes Syntax)))
;; local expansion contexts: pairs of foci, term ;; local expansion contexts: deriv, foci, term
;; context: parameter of Context ;; context: parameter of Context
(define context (make-parameter (lambda (x) x))) (define context (make-parameter (lambda (x) x)))
;; big-context: parameter of BigContext ;; big-context: parameter of BigContext
(define big-context (make-parameter null)) (define big-context (make-parameter null))
;; current-derivation : parameter of Derivation
(define current-derivation (make-parameter #f))
(define-syntax with-context (define-syntax with-context
(syntax-rules () (syntax-rules ()
@ -22,11 +25,18 @@
(let ([E (context)]) (let ([E (context)])
(parameterize ([context (lambda (x) (E (f x)))]) (parameterize ([context (lambda (x) (E (f x)))])
. body))])) . body))]))
(define-syntax with-derivation
(syntax-rules ()
[(with-derivation d . body)
(parameterize ((current-derivation d)) . body)]))
(define-syntax with-new-local-context (define-syntax with-new-local-context
(syntax-rules () (syntax-rules ()
[(with-new-local-context e . body) [(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)]) [context (lambda (x) x)])
. body)])) . body)]))
@ -79,9 +89,9 @@
#'(let-values ([(form2-var foci1-var foci2-var description-var) #'(let-values ([(form2-var foci1-var foci2-var description-var)
(with-syntax ([p f]) (with-syntax ([p f])
(values form2 foci1 foci2 description))]) (values form2 foci1 foci2 description))])
(cons (walk-rename/foci/E foci1-var foci2-var (cons (walk/foci/E foci1-var foci2-var
f form2-var f form2-var
description-var) description-var)
(R** form2-var p . more)))] (R** form2-var p . more)))]
[(R** f p [#:walk form2 description] . more) [(R** f p [#:walk form2 description] . more)
#'(let-values ([(form2-var description-var) #'(let-values ([(form2-var description-var)
@ -106,7 +116,7 @@
;; If this is the key, then insert the misstep here and stop. ;; If this is the key, then insert the misstep here and stop.
;; This stops processing *within* an error-wrapped prim. ;; This stops processing *within* an error-wrapped prim.
(if (or (eq? key #f) (eq? key (cdr info))) (if (or (eq? key #f) (eq? key (cdr info)))
(list (make-misstep f (E f) (car info))) (list (stumble f (car info)))
(continue))] (continue))]
[else [else
(continue)]))] (continue)]))]
@ -115,16 +125,6 @@
#'(let-values ([(reducer get-e1 get-e2) Generator]) #'(let-values ([(reducer get-e1 get-e2) Generator])
(R** f p [reducer get-e1 get-e2 hole0 fill0] . more))] (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 ;; Implementation for (hole ...) sequences
[(R** form-var pattern [(R** form-var pattern
[f0 get-e1 get-e2 (hole0 :::) fill0s] . more) [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. ;; Lifts a local step into a term step.
(define walk (define (walk e1 e2 type)
(case-lambda (make-step (current-derivation) (big-context) type
[(e1 e2) (walk e1 e2 #f)] e1 e2 (E e1) (E e2)))
[(e1 e2 note) (make-rewrite-step e1 e2 (E e1) (E e2) note (big-context))]))
;; 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 ;; stumble : syntax exception -> Reduction
(define (stumble stx exn) (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) (define (revappend a b)
(cond [(pair? a) (revappend (cdr a) (cons (car a) b))] (cond [(pair? a) (revappend (cdr a) (cons (car a) b))]
[(null? a) b])) [(null? a) b]))
) )

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

@ -21,22 +21,31 @@
(syntax-id-rules () (syntax-id-rules ()
[Block (values block-reductions bderiv-es1 bderiv-es2)])) [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
;; reductions : Derivation -> ReductionSequence ;; reductions : Derivation -> ReductionSequence
(define (reductions d) (define (reductions d)
(match d (match/with-derivation d
;; Primitives ;; Primitives
[(struct p:variable (e1 e2 rs)) [(struct p:variable (e1 e2 rs))
(if (bound-identifier=? e1 e2) (if (bound-identifier=? e1 e2)
null null
(list (walk e1 e2 "Resolve variable (remove extra marks)")))] (list (walk e1 e2 'resolve-variable)))]
[(IntQ p:module (e1 e2 rs #f body)) [(IntQ p:module (e1 e2 rs #f body))
(with-syntax ([(?module name language . BODY) e1]) (with-syntax ([(?module name language . BODY) e1])
(let ([ctx (lambda (x) (d->so e1 `(,#'?module ,#'name ,#'language ,x)))] (let ([ctx (lambda (x) (d->so e1 `(,#'?module ,#'name ,#'language ,x)))]
[body-e1 (match body [($$ deriv (body-e1 _) _) body-e1])]) [body-e1 (match body [(AnyQ deriv (body-e1 _)) body-e1])])
(cons (walk e1 (ctx body-e1) "Tag #%module-begin") (cons (walk e1 (ctx body-e1) 'tag-module-begin)
(with-context ctx (with-context ctx
(reductions body)))))] (reductions body)))))]
[(IntQ p:module (e1 e2 rs #t body)) [(IntQ p:module (e1 e2 rs #t body))
@ -106,7 +115,7 @@
[List LDERIV lderiv])]) [List LDERIV lderiv])])
(if (eq? tagged-stx e1) (if (eq? tagged-stx e1)
tail 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) [(AnyQ p:lambda (e1 e2 rs renames body) exni)
(R e1 _ (R e1 _
[! exni] [! exni]
@ -114,7 +123,7 @@
[#:pattern (?lambda ?formals . ?body)] [#:pattern (?lambda ?formals . ?body)]
[#:rename (syntax/skeleton e1 (?lambda ?formals* . ?body*)) [#:rename (syntax/skeleton e1 (?lambda ?formals* . ?body*))
#'?formals #'?formals* #'?formals #'?formals*
"Rename formal parameters"] 'rename-lambda]
[Block ?body body])] [Block ?body body])]
[(struct p:case-lambda (e1 e2 rs renames+bodies)) [(struct p:case-lambda (e1 e2 rs renames+bodies))
#; #;
@ -126,14 +135,14 @@
(syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...)) (syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...))
(syntax->list #'(?formals ...)) (syntax->list #'(?formals ...))
(syntax->list #'(?formals* ...)) (syntax->list #'(?formals* ...))
"Rename formal parameters"] 'rename-case-lambda]
[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)])
(let ([mid (syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...))]) (let ([mid (syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...))])
(cons (walk/foci/E (syntax->list #'(?formals ...)) (cons (walk/foci/E (syntax->list #'(?formals ...))
(syntax->list #'(?formals* ...)) (syntax->list #'(?formals* ...))
e1 mid "Rename formal parameters") e1 mid 'rename-case-lambda)
(R mid (CASE-LAMBDA [FORMALS . BODY] ...) (R mid (CASE-LAMBDA [FORMALS . BODY] ...)
[Block (BODY ...) (map cdr renames+bodies)]))))] [Block (BODY ...) (map cdr renames+bodies)]))))]
[(AnyQ p:let-values (e1 e2 rs renames rhss body) exni) [(AnyQ p:let-values (e1 e2 rs renames rhss body) exni)
@ -145,7 +154,7 @@
(syntax/skeleton e1 (?let-values ([?vars* ?rhs*] ...) . ?body*)) (syntax/skeleton e1 (?let-values ([?vars* ?rhs*] ...) . ?body*))
(syntax->list #'(?vars ...)) (syntax->list #'(?vars ...))
(syntax->list #'(?vars* ...)) (syntax->list #'(?vars* ...))
"Rename bound variables"] 'rename-let-values]
[Expr (?rhs ...) rhss] [Expr (?rhs ...) rhss]
[Block ?body body])] [Block ?body body])]
[(AnyQ p:letrec-values (e1 e2 rs renames rhss body) exni) [(AnyQ p:letrec-values (e1 e2 rs renames rhss body) exni)
@ -157,7 +166,7 @@
(syntax/skeleton e1 (?letrec-values ([?vars* ?rhs*] ...) . ?body*)) (syntax/skeleton e1 (?letrec-values ([?vars* ?rhs*] ...) . ?body*))
(syntax->list #'(?vars ...)) (syntax->list #'(?vars ...))
(syntax->list #'(?vars* ...)) (syntax->list #'(?vars* ...))
"Rename bound variables"] 'rename-letrec-values]
[Expr (?rhs ...) rhss] [Expr (?rhs ...) rhss]
[Block ?body body])] [Block ?body body])]
[(AnyQ p:letrec-syntaxes+values [(AnyQ p:letrec-syntaxes+values
@ -172,34 +181,34 @@
. ?body*)) . ?body*))
(syntax->list #'(?svars ...)) (syntax->list #'(?svars ...))
(syntax->list #'(?svars* ...)) (syntax->list #'(?svars* ...))
"Rename bound variables"] 'rename-lsv]
[Expr (?srhs ...) srhss] [Expr (?srhs ...) srhss]
;; If vrenames is #f, no var bindings to rename ;; If vrenames is #f, no var bindings to rename
[#:if vrenames [#:if vrenames
[#:bind (([?vvars** ?vrhs**] ...) . ?body**) vrenames] [#:bind (([?vvars** ?vrhs**] ...) . ?body**) vrenames]
[#:rename [#:rename
(syntax/skeleton e1 (?lsv ([?svars* ?srhs*] ...) (syntax/skeleton e1 (?lsv ([?svars* ?srhs*] ...)
([?vars** ?vrhs**] ...) ([?vvars** ?vrhs**] ...)
. ?body**)) . ?body**))
(syntax->list #'(?vvars* ...)) (syntax->list #'(?vvars* ...))
(syntax->list #'(?vvars** ...)) (syntax->list #'(?vvars** ...))
"Rename bound variables"]] 'rename-lsv]]
[Expr (?vrhs ...) vrhss] [Expr (?vrhs ...) vrhss]
[Block ?body body] [Block ?body body]
=> (lambda (mid) => (lambda (mid)
(list (walk mid e2 "Remove syntax bindings"))))] (list (walk mid e2 'lsv-remove-syntax))))]
;; The auto-tagged atomic primitives ;; The auto-tagged atomic primitives
[(AnyQ p:#%datum (e1 e2 rs tagged-stx) exni) [(AnyQ p:#%datum (e1 e2 rs tagged-stx) exni)
(append (if (eq? e1 tagged-stx) (append (if (eq? e1 tagged-stx)
null null
(list (walk e1 tagged-stx "Tag datum"))) (list (walk e1 tagged-stx 'tag-datum)))
(if exni (if exni
(list (stumble tagged-stx (car exni))) (list (stumble tagged-stx (car exni)))
null))] null))]
[(AnyQ p:#%top (e1 e2 rs tagged-stx) exni) [(AnyQ p:#%top (e1 e2 rs tagged-stx) exni)
(append (if (eq? e1 tagged-stx) (append (if (eq? e1 tagged-stx)
null null
(list (walk e1 tagged-stx "Tag top-level variable"))) (list (walk e1 tagged-stx 'tag-top)))
(if exni (if exni
(list (stumble tagged-stx (car exni))) (list (stumble tagged-stx (car exni)))
null))] null))]
@ -262,7 +271,7 @@
[(IntQ lift-deriv (e1 e2 first lifted-stx second)) [(IntQ lift-deriv (e1 e2 first lifted-stx second))
(append (reductions first) (append (reductions first)
(list (walk (deriv-e2 first) lifted-stx "Capture lifts")) (list (walk (deriv-e2 first) lifted-stx 'capture-lifts))
(reductions second))] (reductions second))]
;; Skipped ;; Skipped
@ -277,7 +286,7 @@
(match tx (match tx
[(struct transformation (e1 e2 rs me1 me2 locals)) [(struct transformation (e1 e2 rs me1 me2 locals))
(append (reductions-locals e1 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) [(IntW transformation (e1 e2 rs me1 me2 locals) 'locals)
(reductions-locals e1 locals)] (reductions-locals e1 locals)]
[(ErrW transformation (e1 e2 rs me1 me2 locals) 'bad-transformer exn) [(ErrW transformation (e1 e2 rs me1 me2 locals) 'bad-transformer exn)
@ -293,19 +302,19 @@
;; reductions-local : LocalAction -> ReductionSequence ;; reductions-local : LocalAction -> ReductionSequence
(define (reductions-local local) (define (reductions-local local)
(match local (match/with-derivation local
[(struct local-expansion (e1 e2 me1 me2 deriv)) [(struct local-expansion (e1 e2 me1 me2 deriv))
(reductions deriv)] (reductions deriv)]
[(struct local-lift (expr id)) [(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)) [(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)) [(struct local-bind (deriv))
(reductions deriv)])) (reductions deriv)]))
;; list-reductions : ListDerivation -> ReductionSequence ;; list-reductions : ListDerivation -> ReductionSequence
(define (list-reductions ld) (define (list-reductions ld)
(match ld (match/with-derivation ld
[(IntQ lderiv (es1 es2 derivs)) [(IntQ lderiv (es1 es2 derivs))
(let loop ([derivs derivs] [suffix es1]) (let loop ([derivs derivs] [suffix es1])
(cond [(pair? derivs) (cond [(pair? derivs)
@ -323,7 +332,7 @@
;; block-reductions : BlockDerivation -> ReductionSequence ;; block-reductions : BlockDerivation -> ReductionSequence
(define (block-reductions bd) (define (block-reductions bd)
(match bd (match/with-derivation bd
;; If interrupted in pass1, skip pass2 ;; If interrupted in pass1, skip pass2
[(IntW bderiv (es1 es2 pass1 trans pass2) 'pass1) [(IntW bderiv (es1 es2 pass1 trans pass2) 'pass1)
(let-values ([(reductions stxs) (brules-reductions pass1 es1)]) (let-values ([(reductions stxs) (brules-reductions pass1 es1)])
@ -334,8 +343,8 @@
(append reductions1 (append reductions1
(if (eq? trans 'letrec) (if (eq? trans 'letrec)
(match pass2 (match pass2
[($$ lderiv (pass2-es1 _ _) _exni) [(AnyQ lderiv (pass2-es1 _ _))
(list (walk stxs1 pass2-es1 "Transform block to letrec"))]) (list (walk stxs1 pass2-es1 'block->letrec))])
null) null)
(list-reductions pass2)))] (list-reductions pass2)))]
[#f null])) [#f null]))
@ -343,61 +352,63 @@
;; brules-reductions : (list-of-BRule) syntax-list -> ReductionSequence syntax-list ;; brules-reductions : (list-of-BRule) syntax-list -> ReductionSequence syntax-list
(define (brules-reductions brules all-stxs) (define (brules-reductions brules all-stxs)
(let loop ([brules brules] [suffix all-stxs] [prefix null] [rss null]) (let loop ([brules brules] [suffix all-stxs] [prefix null] [rss null])
(match brules (cond [(pair? brules)
[(cons (struct b:expr (renames head)) next) (let ([brule0 (car brules)]
(let ([estx (deriv-e2 head)]) [next (cdr brules)])
(loop next (stx-cdr suffix) (cons estx prefix) (match/with-derivation brule0
(cons (with-context (lambda (x) [(struct b:expr (renames head))
(revappend prefix (cons x (stx-cdr suffix)))) (let ([estx (deriv-e2 head)])
(reductions head)) (loop next (stx-cdr suffix) (cons estx prefix)
rss)))] (cons (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
[(cons (IntW b:expr (renames head) tag) '()) (reductions head))
(loop '() #f #f rss)))]
(cons (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix)))) [(IntW b:expr (renames head) tag)
(reductions head)) (loop next #f #f
rss))] (cons (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
[(cons (struct b:defvals (renames head)) next) (reductions head))
(let ([head-rs rss))]
(with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix)))) [(struct b:defvals (renames head))
(reductions head))]) (let ([head-rs
(loop next (stx-cdr suffix) (cons (deriv-e2 head) prefix) (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
(cons head-rs rss)))] (reductions head))])
[(cons ($$ b:defstx (renames head rhs) _exni) next) (loop next (stx-cdr suffix) (cons (deriv-e2 head) prefix)
(let* ([estx (deriv-e2 head)] (cons head-rs rss)))]
[estx2 (with-syntax ([(?ds ?vars ?rhs) estx] [(AnyQ b:defstx (renames head rhs))
[?rhs* (deriv-e2 rhs)]) (let* ([estx (deriv-e2 head)]
;;FIXME [estx2 (with-syntax ([(?ds ?vars ?rhs) estx]
#'(?ds ?vars ?rhs*))]) [?rhs* (deriv-e2 rhs)])
(loop next (cdr suffix) (cons estx2 prefix) ;;FIXME
(with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix)))) (datum->syntax-object estx `(,#'?ds ,#'?vars ,#'?rhs*) estx estx))])
(cons (with-context (CC (?ds ?vars ?rhs) estx ?rhs) (loop next (cdr suffix) (cons estx2 prefix)
(reductions rhs)) (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
(cons (reductions head) (cons (with-context (CC (?ds ?vars ?rhs) estx ?rhs)
rss)))))] (reductions rhs))
[(cons (struct b:splice (renames head tail)) next) (cons (reductions head)
(loop next tail prefix rss)))))]
(cons (list (walk/foci (deriv-e2 head) [(struct b:splice (renames head tail))
(stx-take tail (loop next tail prefix
(- (stx-improper-length tail) (cons (list (walk/foci (deriv-e2 head)
(stx-improper-length (stx-cdr suffix)))) (stx-take tail
(E (revappend prefix (- (stx-improper-length tail)
(cons (deriv-e2 head) (stx-cdr suffix)))) (stx-improper-length (stx-cdr suffix))))
(E (revappend prefix tail)) (E (revappend prefix
"Splice block-level begin")) (cons (deriv-e2 head) (stx-cdr suffix))))
(cons (with-context (lambda (x) (E (revappend prefix tail))
(revappend prefix (cons x (stx-cdr suffix)))) 'splice-block))
(reductions head)) (cons (with-context (lambda (x)
rss)))] (revappend prefix (cons x (stx-cdr suffix))))
[(cons (struct b:begin (renames head derivs)) next) (reductions head))
;; FIXME rss)))]
(error 'unimplemented)] [(struct b:begin (renames head derivs))
[(cons (struct error-wrap (exn tag _inner)) '()) ;; FIXME
(values (list (make-misstep suffix (E (revappend prefix suffix)) exn)) (error 'unimplemented)]
(revappend prefix suffix))] [(struct error-wrap (exn tag _inner))
['() (values (list (stumble/E suffix (E (revappend prefix suffix)) exn))
(values (apply append (reverse rss)) (revappend prefix suffix))]))]
(revappend prefix suffix))]))) [(null? brules)
(values (apply append (reverse rss))
(revappend prefix suffix))])))
;; mbrules-reductions : MBRules (list-of syntax) -> ReductionSequence ;; mbrules-reductions : MBRules (list-of syntax) -> ReductionSequence
;; The reprocess-on-lift? argument controls the behavior of a mod:lift event. ;; The reprocess-on-lift? argument controls the behavior of a mod:lift event.
;; In Pass1, #t; in Pass2, #f. ;; In Pass1, #t; in Pass2, #f.
@ -408,71 +419,65 @@
(let loop ([mbrules mbrules] [suffix all-stxs] [prefix null]) (let loop ([mbrules mbrules] [suffix all-stxs] [prefix null])
(define (the-context x) (define (the-context x)
(revappend prefix (cons x (stx-cdr suffix)))) (revappend prefix (cons x (stx-cdr suffix))))
;(printf "** MB loop~n") (cond [(pair? mbrules)
;(printf " rules: ~s~n" mbrules) (let ([mbrule0 (car mbrules)]
;(printf " suffix: ~s~n" suffix) [next (cdr mbrules)])
;(printf " prefix: ~s~n" prefix) (match/with-derivation mbrule0
(match mbrules [(struct mod:skip ())
[(cons (struct mod:skip ()) next) (loop next (stx-cdr suffix) (cons (stx-car suffix) prefix))]
(loop next (stx-cdr suffix) (cons (stx-car suffix) prefix))] [(struct mod:cons (head))
[(cons (struct mod:cons (head)) next) (append (with-context the-context (append (reductions head)))
(append (with-context the-context (append (reductions head))) (let ([estx (and (deriv? head) (deriv-e2 head))])
(let ([estx (and (deriv? head) (deriv-e2 head))]) (loop next (stx-cdr suffix) (cons estx prefix))))]
(loop next (stx-cdr suffix) (cons estx prefix))))] [(AnyQ mod:prim (head prim))
[(cons (AnyQ mod:prim (head prim)) next) (append (with-context the-context
(append (with-context the-context (append (reductions head)
(append (reductions head) (reductions prim)))
(reductions prim))) (let ([estx (and (deriv? head) (deriv-e2 head))])
(let ([estx (and (deriv? head) (deriv-e2 head))]) (loop next (stx-cdr suffix) (cons estx prefix))))]
(loop next (stx-cdr suffix) (cons estx prefix))))] [(ErrW mod:splice (head stxs) exn)
[(cons (ErrW mod:splice (head stxs) exn) next) (append (with-context the-context (reductions head))
(append (with-context the-context (reductions head)) (list (stumble (deriv-e2 head) exn)))]
(list (stumble (deriv-e2 head) exn)))] [(struct mod:splice (head stxs))
[(cons (struct mod:splice (head stxs)) next) (append
;(printf "suffix is: ~s~n" suffix) (with-context the-context (reductions head))
;(printf "stxs is: ~s~n" stxs) (let ([suffix-tail (stx-cdr suffix)]
(append [head-e2 (deriv-e2 head)])
(with-context the-context (reductions head)) (cons (walk/foci head-e2
(let ([suffix-tail (stx-cdr suffix)] (stx-take stxs
[head-e2 (deriv-e2 head)]) (- (stx-improper-length stxs)
(cons (walk/foci head-e2 (stx-improper-length suffix-tail)))
(stx-take stxs (E (revappend prefix (cons head-e2 suffix-tail)))
(- (stx-improper-length stxs) (E (revappend prefix stxs))
(stx-improper-length suffix-tail))) 'splice-module)
(E (revappend prefix (cons head-e2 suffix-tail)))
(E (revappend prefix stxs))
"Splice module-level begin")
(loop next stxs prefix))))] (loop next stxs prefix))))]
[(cons (struct mod:lift (head stxs)) next) [(struct mod:lift (head stxs))
;(printf "suffix is: ~s~n~n" suffix) (append
;(printf "stxs is: ~s~n" stxs) (with-context the-context (reductions head))
(append (let ([suffix-tail (stx-cdr suffix)]
(with-context the-context (reductions head)) [head-e2 (deriv-e2 head)])
(let ([suffix-tail (stx-cdr suffix)] (let ([new-suffix (append stxs (cons head-e2 suffix-tail))])
[head-e2 (deriv-e2 head)]) (cons (walk/foci null
(let ([new-suffix (append stxs (cons head-e2 suffix-tail))]) stxs
(cons (walk/foci null (E (revappend prefix (cons head-e2 suffix-tail)))
stxs (E (revappend prefix new-suffix))
(E (revappend prefix (cons head-e2 suffix-tail))) 'splice-lifts)
(E (revappend prefix new-suffix)) (loop next
"Splice definitions from lifted expressions") new-suffix
(loop next prefix)))))]
new-suffix [(struct mod:lift-end (tail))
prefix)))))] (append
[(cons (struct mod:lift-end (tail)) next) (if (pair? tail)
(append (list (walk/foci null
(if (pair? tail) tail
(list (walk/foci null (E (revappend prefix suffix))
tail (E (revappend prefix tail))
(E (revappend prefix suffix)) 'splice-module-lifts))
(E (revappend prefix tail)) null)
"Splice lifted module declarations")) (loop next tail prefix))]))]
null) [(null? mbrules)
(loop next tail prefix))] (set! final-stxs (reverse prefix))
['() null]))])
(set! final-stxs (reverse prefix))
null]))])
(values reductions final-stxs))) (values reductions final-stxs)))
) )

59
collects/macro-debugger/model/steps.ss
View File

@ -3,14 +3,61 @@
(provide (all-defined)) (provide (all-defined))
;; A ReductionSequence is a (list-of Reduction) ;; A ReductionSequence is a (list-of Reduction)
;; A ProtoStep is (make-protostep Derivation BigContext StepType)
;; A Reduction is one of ;; A Reduction is one of
;; - (make-step Syntaxes Syntaxes Syntax Syntax BigContext) ;; - (make-step ... Syntaxes Syntaxes Syntax Syntax)
;; - (make-misstep Syntax Syntax Exception) ;; - (make-misstep ... Syntax Syntax Exception)
(define-struct step (redex contractum e1 e2 note lctx) #f)
(define-struct misstep (redex e1 exn) #f) (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 step-type-meanings
(define-struct (rename-step step) () #f) '((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))))
) )

4
collects/macro-debugger/stepper-text.ss
View File

@ -62,7 +62,7 @@
(define (show-step step partition) (define (show-step step partition)
(cond [(step? step) (cond [(step? step)
(display (step-note step)) (display (step-type->string (protostep-type step)))
(newline) (newline)
(show-term (step-e1 step) partition) (show-term (step-e1 step) partition)
(display " ==>") (display " ==>")
@ -73,7 +73,7 @@
(display (exn-message (misstep-exn step))) (display (exn-message (misstep-exn step)))
(newline) (newline)
(show-term (misstep-e1 step) partition)])) (show-term (misstep-e1 step) partition)]))
(define (show-term stx partition) (define (show-term stx partition)
(define-values (datum flat=>stx stx=>flat) (define-values (datum flat=>stx stx=>flat)
(table stx partition 0 'always)) (table stx partition 0 'always))

98
collects/macro-debugger/view/gui.ss
View File

@ -32,9 +32,9 @@
;; Struct for one-by-one stepping ;; Struct for one-by-one stepping
(define-struct prestep (redex e1 lctx)) (define-struct (prestep protostep) (redex e1))
(define-struct poststep (contractum e2 note lctx)) (define-struct (poststep protostep) (contractum e2))
;; Macro Stepper ;; Macro Stepper
(define view@ (define view@
@ -210,9 +210,6 @@
;; steps : cursor ;; steps : cursor
(define steps #f) (define steps #f)
;; zoomed? : boolean
(define zoomed? #f)
(define warnings-frame #f) (define warnings-frame #f)
(define/public (add-deriv d) (define/public (add-deriv d)
@ -331,17 +328,6 @@
(set! synth-deriv #f)) (set! synth-deriv #f))
(refresh)) (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) (define/private (insert-step-separator text)
(send sbview add-text "\n ") (send sbview add-text "\n ")
(send sbview add-text (send sbview add-text
@ -371,7 +357,7 @@
(update) (update)
(send text scroll-to-position (unbox start-box) #f (unbox end-box))) (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 ;; Show the final terms from the cached synth'd derivs
(for-each (lambda (d+sd) (for-each (lambda (d+sd)
(let ([e2 (lift/deriv-e2 (cdr d+sd))]) (let ([e2 (lift/deriv-e2 (cdr d+sd))])
@ -380,7 +366,7 @@
(send sbview add-text "Error\n")))) (send sbview add-text "Error\n"))))
(reverse derivs-prefix))) (reverse derivs-prefix)))
(define (update:show-current-step) (define/private (update:show-current-step)
(when steps (when steps
(let ([step (cursor:current steps)]) (let ([step (cursor:current steps)])
(cond [(step? step) (cond [(step? step)
@ -394,45 +380,50 @@
[(not step) [(not step)
(update:show-final)])))) (update:show-final)]))))
(define (update:show-lctx lctx) (define/private (update:show-lctx lctx)
(when (pair? lctx) (when (pair? lctx)
(for-each (lambda (bc) (for-each (lambda (bc)
(send sbview add-text "While executing macro transformer in:\n") (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) lctx)
(send sbview add-text "\n"))) (send sbview add-text "\n")))
(define (update:show-step step) (define/private (update:show-protostep step)
(unless zoomed? (update:show-lctx (protostep-lctx step)))
(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 (update:show-prestep step) (define/private (update:separator step)
(update:show-lctx (prestep-lctx step)) (insert-step-separator (step-type->string (protostep-type step))))
(insert-step-separator/small "Find redex")
(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)))) (insert-syntax/redex (prestep-e1 step) (foci (prestep-redex step))))
(define (update:show-poststep step) (define/private (update:show-poststep step)
(update:show-lctx (poststep-lctx step)) (update:show-protostep step)
(insert-step-separator/small (poststep-note step)) (update:separator/small step)
(insert-syntax/contractum (poststep-e2 step) (foci (poststep-contractum 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-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 (exn-message (misstep-exn step)))
(send sbview add-text "\n") (send sbview add-text "\n")
(when (exn:fail:syntax? (misstep-exn step)) (when (exn:fail:syntax? (misstep-exn step))
(for-each (lambda (e) (send sbview add-syntax e)) (for-each (lambda (e) (send sbview add-syntax e))
(exn:fail:syntax-exprs (misstep-exn step))))) (exn:fail:syntax-exprs (misstep-exn step)))))
(define (update:show-final) (define/private (update:show-final)
(let ([result (lift/deriv-e2 synth-deriv)]) (let ([result (lift/deriv-e2 synth-deriv)])
(when result (when result
(send sbview add-text "Expansion finished\n") (send sbview add-text "Expansion finished\n")
@ -440,7 +431,7 @@
(unless result (unless result
(send sbview add-text "Error\n")))) (send sbview add-text "Error\n"))))
(define (update:show-suffix) (define/private (update:show-suffix)
(when (pair? derivs) (when (pair? derivs)
(for-each (lambda (suffix-deriv) (for-each (lambda (suffix-deriv)
(send sbview add-syntax (lift/deriv-e1 suffix-deriv))) (send sbview add-syntax (lift/deriv-e1 suffix-deriv)))
@ -454,7 +445,7 @@
(send text begin-edit-sequence) (send text begin-edit-sequence)
(send sbview erase-all) (send sbview erase-all)
(unless zoomed? (update:show-prefix)) (update:show-prefix)
(send sbview add-separator) (send sbview add-separator)
(set! position-of-interest (send text last-position)) (set! position-of-interest (send text last-position))
(update:show-current-step) (update:show-current-step)
@ -492,15 +483,8 @@
(send nav:end enable (and steps (cursor:can-move-next? steps))) (send nav:end enable (and steps (cursor:can-move-next? steps)))
(send nav:up enable (and (pair? derivs-prefix))) (send nav:up enable (and (pair? derivs-prefix)))
(send nav:down enable (send nav:down enable
(and (pair? derivs))) (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))
;; -- ;; --
;; refresh/resynth : -> void ;; refresh/resynth : -> void
@ -584,13 +568,13 @@
(define/private (reduce:one-by-one rs) (define/private (reduce:one-by-one rs)
(let loop ([rs rs]) (let loop ([rs rs])
(match rs (match rs
[(cons (struct step (redex contractum e1 e2 note lctx)) rs) [(cons (struct step (d l t redex contractum e1 e2)) rs)
(list* (make-prestep redex e1 lctx) (list* (make-prestep d l "Find redex" redex e1)
(make-poststep contractum e2 note lctx) (make-poststep d l t contractum e2)
(loop rs))] (loop rs))]
[(cons (struct misstep (redex e1 exn)) rs) [(cons (struct misstep (d l t redex e1 exn)) rs)
(list* (make-prestep redex e1 null) (list* (make-prestep d l "Find redex" redex e1)
(make-misstep redex e1 exn) (make-misstep d l t redex e1 exn)
(loop rs))] (loop rs))]
['() ['()
null]))) null])))