diff --git a/collects/macro-debugger/model/deriv-parser.ss b/collects/macro-debugger/model/deriv-parser.ss index d5a7bd1..15efd88 100644 --- a/collects/macro-debugger/model/deriv-parser.ss +++ b/collects/macro-debugger/model/deriv-parser.ss @@ -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 diff --git a/collects/macro-debugger/model/deriv-tokens.ss b/collects/macro-debugger/model/deriv-tokens.ss index ad7324e..155f9aa 100644 --- a/collects/macro-debugger/model/deriv-tokens.ss +++ b/collects/macro-debugger/model/deriv-tokens.ss @@ -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) diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss index 7fe33e4..70c19a9 100644 --- a/collects/macro-debugger/model/reductions.ss +++ b/collects/macro-debugger/model/reductions.ss @@ -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))) - (append (reductions head) - (reductions prim)) - (reductions head))) + [(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 ($$ 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