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

Improved handling of lifts in modules

Browse Source 
svn: r4522

original commit: d2fbbc4a9b70421309d3768a119ef64fb761e180
This commit is contained in:
Ryan Culpepper 2006-10-08 04:14:56 +00:00
parent ba6819f1ed
commit b7804c2303
3 changed files with 32 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
collects/macro-debugger/model/deriv-parser.ss
View File

@ -243,17 +243,17 @@
[() null]
[(next (? ModulePass1-Part) (? ModulePass1))
(cons $2 $3)]
[(lift-end-loop (? ModulePass1))
[(module-lift-end-loop (? ModulePass1))
(cons (make-mod:lift-end $1) $2)])
(ModulePass1-Part
(#:no-wrap)
[((? EE) (? ModulePass1/Prim))
(make-mod:prim $1 $2)]
[(EE splice)
(make-mod:splice $1 $2)]
[(EE lift-loop)
(make-mod:lift $1 $2)])
[(EE NoError module-lift-loop)
(make-mod:lift $1 $2)]
[(EE ! splice)
(make-mod:splice $1 $3)])
(ModulePass1/Prim
[(enter-prim prim-define-values ! exit-prim)
@ -277,7 +277,7 @@
[() null]
[(next (? ModulePass2-Part) (? ModulePass2))
(cons $2 $3)]
[(lift-end-loop (? ModulePass2))
[(module-lift-end-loop (? ModulePass2))
(cons (make-mod:lift-end $1) $2)])
(ModulePass2-Part
@ -289,7 +289,7 @@
[((? EE))
(make-mod:cons $1)]
;; catch lifts
[(EE lift-loop)
[(EE module-lift-loop)
(make-mod:lift $1 $2)])
;; Definitions

6
collects/macro-debugger/model/deriv-tokens.ss
View File

@ -31,7 +31,8 @@
syntax-error ; exn
lift-loop ; syntax
lift/let-loop ; syntax
lift-end-loop ; syntax
module-lift-loop ; syntaxes
module-lift-end-loop ; syntaxes
lift ; (cons syntax id)
lift-statement ; syntax
enter-local ; syntax
@ -128,8 +129,9 @@
(132 . ,token-local-pre)
(133 . ,token-local-post)
(134 . ,token-lift-statement)
(135 . ,token-lift-end-loop)
(135 . ,token-module-lift-end-loop)
(136 . ,token-lift/let-loop)
(137 . ,token-module-lift-loop)
))
(define (tokenize sig-n val pos)

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

@ -25,6 +25,7 @@
;; reductions : Derivation -> ReductionSequence
(define (reductions d)
(match d
;; Primitives
[(struct p:variable (e1 e2 rs))
null]
@ -64,7 +65,8 @@
(R e1 _
[! exni]
[#:pattern (?define-values formals RHS)]
[Expr RHS rhs])]
[#:if rhs
[Expr RHS rhs]])]
[(AnyQ p:if (e1 e2 rs full? test then else) exni)
(if full?
(R e1 _
@ -396,34 +398,33 @@
(let* ([final-stxs #f]
[reductions
(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 ($$ mod:skip ()) next)
[(cons (struct mod:skip ()) next)
(loop next (stx-cdr suffix) (cons (stx-car suffix) prefix))]
[(cons ($$ mod:cons (head) _exni) next)
(append (with-context (lambda (x)
(revappend prefix (cons x (stx-cdr suffix))))
(append (reductions head)))
[(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 ($$ mod:prim (head prim) _exni) next)
(append (with-context (lambda (x)
(revappend prefix (cons x (stx-cdr suffix))))
(if (and prim (not (p:define-values? prim)))
[(cons (AnyQ mod:prim (head prim)) next)
(append (with-context the-context
(append (reductions head)
(reductions prim))
(reductions head)))
(reductions prim)))
(let ([estx (and (deriv? head) (deriv-e2 head))])
(loop next (stx-cdr suffix) (cons estx prefix))))]
[(cons ($$ mod:splice (head stxs)) next)
;(printf "suffix is: ~s~n~n" suffix)
[(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 (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
(reductions head))
(with-context the-context (reductions head))
(let ([suffix-tail (stx-cdr suffix)]
[head-e2 (deriv-e2 head)])
(cons (walk/foci head-e2
@ -434,12 +435,11 @@
(E (revappend prefix stxs))
"Splice module-level begin")
(loop next stxs prefix))))]
[(cons ($$ mod:lift (head stxs)) next)
[(cons (struct mod:lift (head stxs)) next)
;(printf "suffix is: ~s~n~n" suffix)
;(printf "stxs is: ~s~n" stxs)
(append
(with-context (lambda (x) (revappend prefix (cons x (stx-cdr suffix))))
(reductions head))
(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))])
@ -451,7 +451,7 @@
(loop next
new-suffix
prefix)))))]
[(cons ($$ mod:lift-end (tail)) next)
[(cons (struct mod:lift-end (tail)) next)
(append
(if (pair? tail)
(list (walk/foci null