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

Macro stepper: added basic expansion-frontier tracking and display

Browse Source 
svn: r5715

original commit: c340b211108b421360e9521247fe8566a70fcabb
This commit is contained in:
Ryan Culpepper 2007-03-01 23:45:55 +00:00
parent 8985123577
commit a4731a40e8
5 changed files with 157 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -15,6 +15,8 @@
outer-rewrap outer-rewrap
lift/deriv-e1 lift/deriv-e1
lift/deriv-e2 lift/deriv-e2
lift/lderiv-es1
lift/lderiv-es2
wrapped? wrapped?
find-derivs find-derivs
@ -131,6 +133,14 @@
(define (lift/deriv-e2 x) (define (lift/deriv-e2 x)
(match x (match x
[(AnyQ deriv (_ e2)) e2])) [(AnyQ deriv (_ e2)) e2]))
(define (lift/lderiv-es1 x)
(match x
[(AnyQ lderiv (es1 es2 _)) es1]))
(define (lift/lderiv-es2 x)
(match x
[(AnyQ lderiv (es1 es2 _)) es2]))
(define (wrapped? x) (define (wrapped? x)
(or (interrupted-wrap? x) (or (interrupted-wrap? x)

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

@ -1,6 +1,7 @@
(module reductions-engine mzscheme (module reductions-engine mzscheme
(require "deriv.ss" (require (lib "list.ss")
"deriv.ss"
"stx-util.ss" "stx-util.ss"
"steps.ss") "steps.ss")
(provide (all-from "steps.ss")) (provide (all-from "steps.ss"))
@ -10,6 +11,10 @@
current-derivation current-derivation
current-definites current-definites
learn-definites learn-definites
current-frontier
add-frontier
blaze-frontier
rename-frontier
with-context with-context
with-derivation with-derivation
with-new-local-context with-new-local-context
@ -33,12 +38,15 @@
;; current-definites : parameter of (list-of identifier) ;; current-definites : parameter of (list-of identifier)
(define current-definites (make-parameter null)) (define current-definites (make-parameter null))
;; current-frontier : parameter of (list-of syntax)
(define current-frontier (make-parameter null))
(define-syntax with-context (define-syntax with-context
(syntax-rules () (syntax-rules ()
[(with-context f . body) [(with-context f . body)
(let ([c (context)]) (let ([c (context)])
(parameterize ([context (cons f c)]) (parameterize ([context (cons f c)])
. body))])) (let () . body)))]))
(define-syntax with-derivation (define-syntax with-derivation
(syntax-rules () (syntax-rules ()
@ -57,6 +65,17 @@
(define (learn-definites ids) (define (learn-definites ids)
(current-definites (append ids (current-definites)))) (current-definites (append ids (current-definites))))
(define (add-frontier stxs)
(current-frontier (append stxs (current-frontier)))
#;(printf "new frontier: ~s~n" (current-frontier)))
(define (blaze-frontier stx)
#;(unless (memq stx (current-frontier))
(fprintf (current-error-port) "frontier does not contain term: ~s~n" stx)
(error 'blaze-frontier))
(current-frontier (remq stx (current-frontier)))
#;(printf "new frontier (blazed): ~s~n" (current-frontier)))
;; ----------------------------------- ;; -----------------------------------
;; CC ;; CC
@ -86,7 +105,7 @@
#'(R** f p2 . more)] #'(R** f p2 . more)]
;; Bind pattern variables ;; Bind pattern variables
[(R** f p [#:bind pattern rhs] . more) [(R** f p [#:bind pattern rhs] . more)
#'(with-syntax ([pattern rhs]) #'(with-syntax ([pattern (with-syntax ([p f]) rhs)])
(R** f p . more))] (R** f p . more))]
;; Change syntax ;; Change syntax
[(R** f p [#:set-syntax form] . more) [(R** f p [#:set-syntax form] . more)
@ -103,6 +122,7 @@
#'(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))])
(rename-frontier f form2-var)
(with-context (make-renames foci1-var foci2-var) (with-context (make-renames foci1-var foci2-var)
(cons (walk/foci foci1-var foci2-var (cons (walk/foci foci1-var foci2-var
f form2-var f form2-var
@ -117,6 +137,9 @@
[(R** f p [#:learn ids] . more) [(R** f p [#:learn ids] . more)
#'(begin (learn-definites ids) #'(begin (learn-definites ids)
(R** f p . more))] (R** f p . more))]
[(R** f p [#:frontier stxs] . more)
#'(begin (add-frontier (with-syntax ([p f]) stxs))
(R** f p . more))]
;; Conditional ;; Conditional
[(R** f p [#:if test consequent ...] . more) [(R** f p [#:if test consequent ...] . more)
@ -183,28 +206,64 @@
(let ([form-var (ctx0 (get-e2 fill0))]) (let ([form-var (ctx0 (get-e2 fill0))])
(R** form-var pattern . more))])))])) (R** form-var pattern . more))])))]))
;; Rename mapping
(define (rename-frontier from to)
(current-frontier (apply append (map (make-rename-mapping from to) (current-frontier)))))
(define (make-rename-mapping from to)
(define table (make-hash-table))
(let loop ([from from] [to to])
(cond [(syntax? from)
(hash-table-put! table from (flatten-syntaxes to))
(loop (syntax-e from) to)]
[(syntax? to)
(loop from (syntax-e to))]
[(pair? from)
(loop (car from) (car to))
(loop (cdr from) (cdr to))]
[(vector? from)
(loop (vector->list from) (vector->list to))]
[else (void)]))
(lambda (stx)
(let ([replacement (hash-table-get table stx #f)])
(if replacement
(begin #;(printf " replacing ~s with ~s~n" stx replacement)
replacement)
(begin #;(printf " not replacing ~s~n" stx)
(list stx))))))
(define (flatten-syntaxes x)
(cond [(syntax? x)
(list x)]
[(pair? x)
(append (flatten-syntaxes (car x) (cdr x)))]
[(vector? x)
(flatten-syntaxes (vector->list x))]
[else null]))
;; ----------------------------------- ;; -----------------------------------
;; walk : syntax(es) syntax(es) StepType -> Reduction ;; walk : syntax(es) syntax(es) StepType -> Reduction
;; Lifts a local step into a term step. ;; Lifts a local step into a term step.
(define (walk e1 e2 type) (define (walk e1 e2 type)
(make-step (current-derivation) (big-context) type (context) (current-definites) (make-step (current-derivation) (big-context) type (context) (current-definites) (current-frontier)
(foci e1) (foci e2) e1 e2)) (foci e1) (foci e2) e1 e2))
;; walk/foci : syntaxes syntaxes syntax syntax StepType -> Reduction ;; walk/foci : syntaxes syntaxes syntax syntax StepType -> Reduction
(define (walk/foci foci1 foci2 Ee1 Ee2 type) (define (walk/foci foci1 foci2 Ee1 Ee2 type)
(make-step (current-derivation) (big-context) type (context) (current-definites) (make-step (current-derivation) (big-context) type (context) (current-definites) (current-frontier)
(foci foci1) (foci foci2) Ee1 Ee2)) (foci foci1) (foci foci2) Ee1 Ee2))
;; stumble : syntax exception -> Reduction ;; stumble : syntax exception -> Reduction
(define (stumble stx exn) (define (stumble stx exn)
(make-misstep (current-derivation) (big-context) 'error (context) (current-definites) (make-misstep (current-derivation) (big-context) 'error (context) (current-definites) (current-frontier)
(foci stx) stx exn)) (foci stx) stx exn))
;; stumble/E : syntax(s) syntax exn -> Reduction ;; stumble/E : syntax(s) syntax exn -> Reduction
(define (stumble/E focus Ee1 exn) (define (stumble/E focus Ee1 exn)
(make-misstep (current-derivation) (big-context) 'error (context) (current-definites) (make-misstep (current-derivation) (big-context) 'error (context) (current-definites) (current-frontier)
(foci focus) Ee1 exn)) (foci focus) Ee1 exn))
;; ------------------------------------ ;; ------------------------------------

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

@ -34,13 +34,16 @@
;; reductions : Derivation -> ReductionSequence ;; reductions : Derivation -> ReductionSequence
(define (reductions d) (define (reductions d)
(parameterize ((current-definites null)) (parameterize ((current-definites null)
(current-frontier null))
(add-frontier (list (lift/deriv-e1 d)))
(reductions* d))) (reductions* d)))
(define (reductions* d) (define (reductions* d)
(match d (match d
[(AnyQ prule (e1 e2 rs)) [(AnyQ prule (e1 e2 rs))
(and rs (learn-definites rs))] (and rs (learn-definites rs))
(blaze-frontier e1)]
[_ (void)]) [_ (void)])
(match/with-derivation d (match/with-derivation d
@ -56,20 +59,24 @@
[body-e1 (match body [(AnyQ 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
(add-frontier (list (lift/deriv-e1 body)))
(reductions* body)))))] (reductions* body)))))]
[(IntQ p:module (e1 e2 rs #t body)) [(IntQ p:module (e1 e2 rs #t 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)))])
(with-context ctx (with-context ctx
(add-frontier (list (lift/deriv-e1 body)))
(reductions* body))))] (reductions* body))))]
[(AnyQ p:#%module-begin (e1 e2 rs pass1 pass2)) [(AnyQ p:#%module-begin (e1 e2 rs pass1 pass2))
(with-syntax ([(?#%module-begin form ...) e1]) (with-syntax ([(?#%module-begin form ...) e1])
(let ([frame (lambda (x) (d->so e1 (cons #'?#%module-begin x)))]) (let ([frame (lambda (x) (d->so e1 (cons #'?#%module-begin x)))])
(let-values ([(reductions1 final-stxs1) (let-values ([(reductions1 final-stxs1)
(with-context frame (with-context frame
(add-frontier (syntax->list #'(form ...)))
(mbrules-reductions pass1 (syntax->list #'(form ...)) #t))]) (mbrules-reductions pass1 (syntax->list #'(form ...)) #t))])
(let-values ([(reductions2 final-stxs2) (let-values ([(reductions2 final-stxs2)
(with-context frame (with-context frame
;(add-frontier final-stxs1)
(mbrules-reductions pass2 final-stxs1 #f))]) (mbrules-reductions pass2 final-stxs1 #f))])
(if (error-wrap? d) (if (error-wrap? d)
(append reductions1 reductions2 (append reductions1 reductions2
@ -79,11 +86,13 @@
(R e1 (R e1
[! exni] [! exni]
[#:pattern (?define-syntaxes formals RHS)] [#:pattern (?define-syntaxes formals RHS)]
[#:frontier (list #'RHS)]
[Expr RHS rhs])] [Expr RHS rhs])]
[(AnyQ p:define-values (e1 e2 rs rhs) exni) [(AnyQ p:define-values (e1 e2 rs rhs) exni)
(R e1 (R e1
[! exni] [! exni]
[#:pattern (?define-values formals RHS)] [#:pattern (?define-values formals RHS)]
[#:frontier (list #'RHS)]
[#:if rhs [#:if rhs
[Expr RHS rhs]])] [Expr RHS rhs]])]
[(AnyQ p:if (e1 e2 rs full? test then else) exni) [(AnyQ p:if (e1 e2 rs full? test then else) exni)
@ -91,18 +100,21 @@
(R e1 (R e1
[! exni] [! exni]
[#:pattern (?if TEST THEN ELSE)] [#:pattern (?if TEST THEN ELSE)]
[#:frontier (list #'TEST #'THEN #'ELSE)]
[Expr TEST test] [Expr TEST test]
[Expr THEN then] [Expr THEN then]
[Expr ELSE else]) [Expr ELSE else])
(R e1 (R e1
[! exni] [! exni]
[#:pattern (?if TEST THEN)] [#:pattern (?if TEST THEN)]
[#:frontier (list #'TEST #'THEN)]
[Expr TEST test] [Expr TEST test]
[Expr THEN then]))] [Expr THEN then]))]
[(AnyQ p:wcm (e1 e2 rs key mark body) exni) [(AnyQ p:wcm (e1 e2 rs key mark body) exni)
(R e1 (R e1
[! exni] [! exni]
[#:pattern (?wcm KEY MARK BODY)] [#:pattern (?wcm KEY MARK BODY)]
[#:frontier (list #'KEY #'MARK #'BODY)]
[Expr KEY key] [Expr KEY key]
[Expr MARK mark] [Expr MARK mark]
[Expr BODY body])] [Expr BODY body])]
@ -110,11 +122,13 @@
(R e1 (R e1
[! exni] [! exni]
[#:pattern (?begin . LDERIV)] [#:pattern (?begin . LDERIV)]
[#:frontier (stx->list #'LDERIV)]
[List LDERIV lderiv])] [List LDERIV lderiv])]
[(AnyQ p:begin0 (e1 e2 rs first lderiv) exni) [(AnyQ p:begin0 (e1 e2 rs first lderiv) exni)
(R e1 (R e1
[! exni] [! exni]
[#:pattern (?begin0 FIRST . LDERIV)] [#:pattern (?begin0 FIRST . LDERIV)]
[#:frontier (cons #'FIRST (stx->list #'LDERIV))]
[Expr FIRST first] [Expr FIRST first]
[List LDERIV lderiv])] [List LDERIV lderiv])]
[(AnyQ p:#%app (e1 e2 rs tagged-stx lderiv) exni) [(AnyQ p:#%app (e1 e2 rs tagged-stx lderiv) exni)
@ -122,6 +136,7 @@
(R tagged-stx (R tagged-stx
[! exni] [! exni]
[#:pattern (?#%app . LDERIV)] [#:pattern (?#%app . LDERIV)]
[#:frontier (stx->list #'LDERIV)]
[List LDERIV lderiv])]) [List LDERIV lderiv])])
(if (eq? tagged-stx e1) (if (eq? tagged-stx e1)
tail tail
@ -131,6 +146,7 @@
[! exni] [! exni]
[#:bind (?formals* . ?body*) renames] [#:bind (?formals* . ?body*) renames]
[#:pattern (?lambda ?formals . ?body)] [#:pattern (?lambda ?formals . ?body)]
[#:frontier (stx->list #'?body)]
[#:rename (syntax/skeleton e1 (?lambda ?formals* . ?body*)) [#:rename (syntax/skeleton e1 (?lambda ?formals* . ?body*))
#'?formals #'?formals* #'?formals #'?formals*
'rename-lambda] 'rename-lambda]
@ -140,6 +156,7 @@
(R e1 (R e1
[! exni] [! exni]
[#:pattern (?case-lambda [?formals . ?body] ...)] [#:pattern (?case-lambda [?formals . ?body] ...)]
;; FIXME: frontier
[#:bind [(?formals* . ?body*) ...] (map car renames+bodies)] [#:bind [(?formals* . ?body*) ...] (map car renames+bodies)]
[#:rename [#:rename
(syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...)) (syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...))
@ -161,6 +178,7 @@
(R e1 (R e1
[! exni] [! exni]
[#:pattern (?let-values ([?vars ?rhs] ...) . ?body)] [#:pattern (?let-values ([?vars ?rhs] ...) . ?body)]
[#:frontier (append (syntax->list #'(?rhs ...)) (stx->list #'?body))]
[#:bind (([?vars* ?rhs*] ...) . ?body*) renames] [#:bind (([?vars* ?rhs*] ...) . ?body*) renames]
[#:rename [#:rename
(syntax/skeleton e1 (?let-values ([?vars* ?rhs*] ...) . ?body*)) (syntax/skeleton e1 (?let-values ([?vars* ?rhs*] ...) . ?body*))
@ -173,6 +191,7 @@
(R e1 (R e1
[! exni] [! exni]
[#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)] [#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)]
[#:frontier (append (syntax->list #'(?rhs ...)) (stx->list #'?body))]
[#:bind (([?vars* ?rhs*] ...) . ?body*) renames] [#:bind (([?vars* ?rhs*] ...) . ?body*) renames]
[#:rename [#:rename
(syntax/skeleton e1 (?letrec-values ([?vars* ?rhs*] ...) . ?body*)) (syntax/skeleton e1 (?letrec-values ([?vars* ?rhs*] ...) . ?body*))
@ -186,6 +205,9 @@
(R e1 (R e1
[! exni] [! exni]
[#:pattern (?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body)] [#:pattern (?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body)]
[#:frontier (append (syntax->list #'(?srhs ...))
(syntax->list #'(?vrhs ...))
(stx->list #'?body))]
[#:bind (([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...) . ?body*) srenames] [#:bind (([?svars* ?srhs*] ...) ([?vvars* ?vrhs*] ...) . ?body*) srenames]
[#:rename [#:rename
(syntax/skeleton e1 (syntax/skeleton e1
@ -235,17 +257,20 @@
[(AnyQ p:set!-macro (e1 e2 rs deriv) exni) [(AnyQ p:set!-macro (e1 e2 rs deriv) exni)
(R e1 (R e1
[! exni] [! exni]
[#:frontier (list e1)]
=> (lambda (mid) => (lambda (mid)
(reductions* deriv)))] (reductions* deriv)))]
[(AnyQ p:set! (e1 e2 rs id-rs rhs) exni) [(AnyQ p:set! (e1 e2 rs id-rs rhs) exni)
(R e1 (R e1
[! exni] [! exni]
[#:pattern (SET! VAR RHS)] [#:pattern (SET! VAR RHS)]
[#:frontier (list #'RHS)]
[#:learn id-rs] [#:learn id-rs]
[Expr RHS rhs])] [Expr RHS rhs])]
;; Synthetic primitives ;; Synthetic primitives
;; These have their own subterm replacement mechanisms ;; These have their own subterm replacement mechanisms
;; FIXME: Frontier
[(and d (AnyQ p:synth (e1 e2 rs subterms))) [(and d (AnyQ p:synth (e1 e2 rs subterms)))
(let loop ([term e1] [subterms subterms]) (let loop ([term e1] [subterms subterms])
(cond [(null? subterms) (cond [(null? subterms)
@ -274,17 +299,22 @@
;; FIXME ;; FIXME
[(IntQ p:rename (e1 e2 rs rename inner)) [(IntQ p:rename (e1 e2 rs rename inner))
;; FIXME: frontier
(reductions* inner)] (reductions* inner)]
;; Error ;; Error
;; Macros ;; Macros
[(IntQ mrule (e1 e2 transformation next)) [(IntQ mrule (e1 e2 transformation next))
(blaze-frontier e1)
;;(printf "frontier for mrule: ~s~n" (current-frontier))
(append (reductions-transformation transformation) (append (reductions-transformation transformation)
(reductions* next))] (begin (add-frontier (list (lift/deriv-e1 next)))
(reductions* next)))]
;; Lifts ;; Lifts
;; FIXME: frontier
[(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))
@ -366,7 +396,8 @@
[(AnyQ lderiv (pass2-es1 _ _)) [(AnyQ lderiv (pass2-es1 _ _))
(list (walk stxs1 pass2-es1 'block->letrec))]) (list (walk stxs1 pass2-es1 'block->letrec))])
null) null)
(list-reductions pass2)))] (begin (add-frontier (stx->list (lift/lderiv-es1 pass2)))
(list-reductions pass2))))]
[#f null])) [#f null]))
;; brules-reductions : (list-of-BRule) syntax-list -> ReductionSequence syntax-list ;; brules-reductions : (list-of-BRule) syntax-list -> ReductionSequence syntax-list
@ -377,23 +408,27 @@
[next (cdr brules)]) [next (cdr brules)])
(match/with-derivation brule0 (match/with-derivation brule0
[(struct b:expr (renames head)) [(struct b:expr (renames head))
(rename-frontier (car renames) (cdr renames))
(let ([estx (deriv-e2 head)]) (let ([estx (deriv-e2 head)])
(loop next (stx-cdr suffix) (cons estx prefix) (loop next (stx-cdr suffix) (cons estx prefix)
(cons (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix)))) (cons (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
(reductions* head)) (reductions* head))
rss)))] rss)))]
[(IntW b:expr (renames head) tag) [(IntW b:expr (renames head) tag)
(rename-frontier (car renames) (cdr renames))
(loop next #f #f (loop next #f #f
(cons (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix)))) (cons (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
(reductions* head)) (reductions* head))
rss))] rss))]
[(struct b:defvals (renames head)) [(struct b:defvals (renames head))
(rename-frontier (car renames) (cdr renames))
(let ([head-rs (let ([head-rs
(with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix)))) (with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
(reductions* head))]) (reductions* head))])
(loop next (stx-cdr suffix) (cons (deriv-e2 head) prefix) (loop next (stx-cdr suffix) (cons (deriv-e2 head) prefix)
(cons head-rs rss)))] (cons head-rs rss)))]
[(AnyQ b:defstx (renames head rhs)) [(AnyQ b:defstx (renames head rhs))
(rename-frontier (car renames) (cdr renames))
(let* ([estx (deriv-e2 head)] (let* ([estx (deriv-e2 head)]
[estx2 (and (deriv? rhs) [estx2 (and (deriv? rhs)
(with-syntax ([(?ds ?vars ?rhs) estx] (with-syntax ([(?ds ?vars ?rhs) estx]
@ -408,6 +443,7 @@
(cons (reductions* head) (cons (reductions* head)
rss)))))] rss)))))]
[(struct b:splice (renames head tail)) [(struct b:splice (renames head tail))
(rename-frontier (car renames) (cdr renames))
(loop next tail prefix (loop next tail prefix
(cons (list (walk/foci (deriv-e2 head) (cons (list (walk/foci (deriv-e2 head)
(stx-take tail (stx-take tail
@ -439,44 +475,62 @@
(let* ([final-stxs #f] (let* ([final-stxs #f]
[reductions [reductions
(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))))
(cond [(pair? mbrules) (cond [(pair? mbrules)
(let ([mbrule0 (car mbrules)] (let ([mbrule0 (car mbrules)]
[next (cdr mbrules)]) [next (cdr mbrules)])
(match/with-derivation mbrule0 (match/with-derivation mbrule0
[(struct mod:skip ()) [(struct mod:skip ())
;(blaze-frontier (stx-car suffix))
(loop next (stx-cdr suffix) (cons (stx-car suffix) prefix))] (loop next (stx-cdr suffix) (cons (stx-car suffix) prefix))]
[(struct mod:cons (head)) [(struct mod:cons (head))
;(blaze-frontier (stx-car suffix))
(rename-frontier (stx-car suffix) (lift/deriv-e1 head))
(add-frontier (list (lift/deriv-e1 head)))
(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)) [(AnyQ mod:prim (head prim))
;(blaze-frontier (stx-car suffix))
(rename-frontier (stx-car suffix) (lift/deriv-e1 head))
(add-frontier (list (lift/deriv-e1 head)))
(append (with-context the-context (append (with-context the-context
(append (reductions* head) (append (reductions* head)
(reductions* prim))) (begin
(when prim
(add-frontier (list (lift/deriv-e1 prim))))
(reductions* prim))))
(let ([estx (let ([estx
(if prim (if prim
(lift/deriv-e2 prim) (lift/deriv-e2 prim)
(and (deriv? head) (deriv-e2 head)))]) (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) [(ErrW mod:splice (head stxs) exn)
;(blaze-frontier (stx-car suffix))
(rename-frontier (stx-car suffix) (lift/deriv-e1 head))
(add-frontier (list (lift/deriv-e1 head)))
(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)) [(struct mod:splice (head stxs))
;(blaze-frontier (stx-car suffix))
(rename-frontier (stx-car suffix) (lift/deriv-e1 head))
(add-frontier (list (lift/deriv-e1 head)))
(append (append
(with-context the-context (reductions* head)) (with-context the-context (reductions* head))
(let ([suffix-tail (stx-cdr suffix)] (let ([suffix-tail (stx-cdr suffix)]
[head-e2 (deriv-e2 head)]) [head-e2 (deriv-e2 head)])
(cons (walk/foci head-e2 (let ([new-stxs (stx-take stxs
(stx-take stxs (- (stx-improper-length stxs)
(- (stx-improper-length stxs) (stx-improper-length suffix-tail)))])
(stx-improper-length suffix-tail))) (cons (walk/foci head-e2
(revappend prefix (cons head-e2 suffix-tail)) new-stxs
(revappend prefix stxs) (revappend prefix (cons head-e2 suffix-tail))
'splice-module) (revappend prefix stxs)
(loop next stxs prefix))))] 'splice-module)
(begin (add-frontier new-stxs)
(loop next stxs prefix))))))]
[(struct mod:lift (head stxs)) [(struct mod:lift (head stxs))
;; FIXME: frontier
(append (append
(with-context the-context (reductions* head)) (with-context the-context (reductions* head))
(let ([suffix-tail (stx-cdr suffix)] (let ([suffix-tail (stx-cdr suffix)]
@ -491,6 +545,7 @@
new-suffix new-suffix
prefix)))))] prefix)))))]
[(struct mod:lift-end (tail)) [(struct mod:lift-end (tail))
;; FIXME: frontier
(append (append
(if (pair? tail) (if (pair? tail)
(list (walk/foci null (list (walk/foci null

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

@ -24,7 +24,7 @@
;; - (make-step ... Syntaxes Syntaxes Syntax Syntax) ;; - (make-step ... Syntaxes Syntaxes Syntax Syntax)
;; - (make-misstep ... Syntax Syntax Exception) ;; - (make-misstep ... Syntax Syntax Exception)
(define-struct protostep (deriv lctx type ctx definites) #f) (define-struct protostep (deriv lctx type ctx definites frontier) #f)
(define-struct (step protostep) (foci1 foci2 e1 e2) #f) (define-struct (step protostep) (foci1 foci2 e1 e2) #f)
(define-struct (misstep protostep) (foci1 e1 exn) #f) (define-struct (misstep protostep) (foci1 e1 exn) #f)

13
collects/macro-debugger/syntax-browser/widget.ss
View File

@ -96,11 +96,16 @@
(send -text insert text))) (send -text insert text)))
(define/public add-syntax (define/public add-syntax
(lambda/kw (stx #:key [hi-stxs null] hi-color alpha-table [definites null]) (lambda/kw (stx #:key [hi-stxs null] hi-color alpha-table [definites null]
hi2-color [hi2-stxs null])
(when (and (pair? hi-stxs) (not hi-color)) (when (and (pair? hi-stxs) (not hi-color))
(error 'syntax-widget%::add-syntax "no highlight color specified")) (error 'syntax-widget%::add-syntax "no highlight color specified"))
(let ([colorer (internal-add-syntax stx hi-stxs hi-color)] (let ([colorer (internal-add-syntax stx)]
[definite-table (make-hash-table)]) [definite-table (make-hash-table)])
(when (and hi2-color (pair? hi2-stxs))
(send colorer highlight-syntaxes hi2-stxs hi2-color))
(when (and hi-color (pair? hi-stxs))
(send colorer highlight-syntaxes hi-stxs hi-color))
(for-each (lambda (x) (hash-table-put! definite-table x #t)) definites) (for-each (lambda (x) (hash-table-put! definite-table x #t)) definites)
(when alpha-table (when alpha-table
(let ([range (send colorer get-range)]) (let ([range (send colorer get-range)])
@ -144,7 +149,7 @@
(define/public (get-text) -text) (define/public (get-text) -text)
(define/private (internal-add-syntax stx hi-stxs hi-color) (define/private (internal-add-syntax stx)
(with-unlock -text (with-unlock -text
(parameterize ((current-default-columns (calculate-columns))) (parameterize ((current-default-columns (calculate-columns)))
(let ([current-position (send -text last-position)]) (let ([current-position (send -text last-position)])
@ -156,8 +161,6 @@
(send* -text (send* -text
(insert "\n") (insert "\n")
(scroll-to-position current-position)) (scroll-to-position current-position))
(unless (null? hi-stxs)
(send new-colorer highlight-syntaxes hi-stxs hi-color))
new-colorer))))) new-colorer)))))
(define/private (calculate-columns) (define/private (calculate-columns)