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
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

View File

@ -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)

View File

@ -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)])])]

View File

@ -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]))
)

View File

@ -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)))
)

View File

@ -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))))
)

View File

@ -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))

View File

@ -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])))