Improved handling of lifts in modules

svn: r4522

original commit: d2fbbc4a9b70421309d3768a119ef64fb761e180

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)
+       [(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
        [(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

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)

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)
+                [(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))])
                            (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))))
+                           (append (reductions head)
-                           (if (and prim (not (p:define-values? prim)))
+                                   (reductions prim)))
-                               (append (reductions head)
-                                       (reductions prim))
-                               (reductions head)))
                          (let ([estx (and (deriv? head) (deriv-e2 head))])
                            (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)
                  (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)]
                         [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))))
+                  (with-context the-context (reductions head))
-                                (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