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

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

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

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

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