macro-stepper: add support for #%stratified-body

original commit: b8bf5c571ac8d51014f4b03c8dfcd30d621add77

collects/macro-debugger/model/deriv-c.rkt

@@ -94,6 +94,9 @@
 ;;   (make-p:require <Base> (listof LocalAction))
 (define-struct (p:require prule) (locals) #:transparent)
 
+;;   (make-p:#%stratified-body <Base> BDeriv)
+(define-struct (p:#%stratified-body prule) (bderiv) #:transparent)
+
 ;;   (make-p:stop <Base>)
 ;;   (make-p:unknown <Base>)
 ;;   (make-p:#%top <Base> Stx)

collects/macro-debugger/model/deriv-parser.rkt

@@ -260,7 +260,8 @@
      [((? PrimQuoteSyntax)) ($1 e1 e2 rs)]
      [((? PrimRequire)) ($1 e1 e2 rs)]
      [((? PrimProvide)) ($1 e1 e2 rs)]
-     [((? PrimVarRef)) ($1 e1 e2 rs)])
+     [((? PrimVarRef)) ($1 e1 e2 rs)]
+     [((? PrimStratifiedBody)) ($1 e1 e2 rs)])
 
     (PrimModule
      (#:args e1 e2 rs)
@@ -472,6 +473,10 @@
      (#:args e1 e2 rs)
      [(prim-varref !) (make p:#%variable-reference e1 e2 rs $2)])
 
+    (PrimStratifiedBody
+     (#:args e1 e2 rs)
+     [(prim-#%stratified-body ! (? EB)) (make p:#%stratified-body e1 e2 rs $2 $3)])
+
     (PrimSet
      (#:args e1 e2 rs)
      ;; Unrolled to avoid shift/reduce

collects/macro-debugger/model/deriv-tokens.rkt

@@ -83,6 +83,7 @@
    prim-set!
    prim-expression
    prim-varref
+   prim-#%stratified-body
    ))
 
 ;; ** Signals to tokens
@@ -174,6 +175,7 @@
     (149 prim-varref)
     (150 lift-require            ,token-lift-require)
     (151 lift-provide            ,token-lift-provide)
+    (155 prim-#%stratified-body)
     ))
 
 (define (signal->symbol sig)

collects/macro-debugger/model/reductions.rkt

@@ -229,6 +229,15 @@
         [#:pattern ?form]
         [LocalActions ?form locals])]
 
+    [(Wrap p:#%stratified-body (e1 e2 rs ?1 bderiv))
+     (R [! ?1]
+        [#:pass1]
+        [#:pattern (?sb . ?body)]
+        [Block ?body bderiv]
+        [#:pass2]
+        [#:pattern ?form]
+        [#:walk e2 'macro])]
+
     [(Wrap p:stop (e1 e2 rs ?1))
      (R [! ?1])]
 

collects/tests/macro-debugger/all-tests.rkt

@@ -1,7 +1,6 @@
 #lang scheme/base
 (require rackunit
-         rackunit/gui)
+         macro-debugger/model/debug
-(require macro-debugger/model/debug
          "gentest-framework.ss"
          "gentests.ss"
          "test-setup.ss"
@@ -12,11 +11,16 @@
          "tests/hiding.ss"
          "tests/regression.ss"
          "tests/policy.ss"
-         "tests/collects.ss")
+         ;;"tests/collects.ss"
-(provide go)
+         )
+(provide all-tests)
 
+#|
+(require rackunit/gui)
 (define (go) (test/gui all-tests))
 (define (collects) (test/gui big-libs-tests))
+(provide go)
+|#
 
 (define protos
   (list proto:kernel-forms
@@ -30,6 +34,11 @@
 (define hiding-deriv-test (mk-hidden-deriv-test protos))
 (define hiding-steps-test (mk-hidden-steps-test protos))
 
+(provide deriv-test
+         steps-test
+         hiding-deriv-test
+         hiding-steps-test)
+
 (define all-tests
   (test-suite "All tests"
     deriv-test
@@ -38,5 +47,4 @@
     hiding-steps-test
     specialized-hiding-tests
     regression-tests
-    #;seek-tests
     policy-tests))

collects/tests/macro-debugger/gentests.rkt

@@ -41,23 +41,25 @@
 (define (checker-for-deriv label form attrs)
   (cond [(assq '#:ok-deriv? attrs)
          => (lambda (key+expect-ok?)
+              (delay-test
                (test-case label
                  (let ([d (trace/ns form (assq '#:kernel attrs))])
                    (check-pred deriv? d)
                    (if (cdr key+expect-ok?)
                        (check-pred ok-node? d)
-                      (check-pred interrupted-node? d)))))]
+                       (check-pred interrupted-node? d))))))]
         [else #f]))
 
 (define (checker-for-hidden-deriv label form attrs)
   (cond [(assq '#:ok-deriv? attrs)
          => (lambda (key+expect-ok?)
+              (delay-test
                (test-case label
                  (let ([d (trace/ns form (assq '#:kernel attrs))]
                        [expect-ok? (cdr key+expect-ok?)])
                    (check-hide d hide-none-policy expect-ok?)
                    (check-hide d hide-all-policy expect-ok?)
-                  (check-hide d T-policy expect-ok?))))]
+                   (check-hide d T-policy expect-ok?)))))]
         [else #f]))
 
 (define (check-hide d policy expect-ok?)
@@ -74,28 +76,31 @@
 (define (checker-for-steps label form attrs)
   (cond [(assq '#:steps attrs)
          => (lambda (key+expected)
+              (delay-test
                (test-case label
                  (let* ([d (trace/ns form (assq '#:kernel attrs))]
                         [rs (reductions d)])
-                  (check-steps (cdr key+expected) rs))))]
+                   (check-steps (cdr key+expected) rs)))))]
         [else #f]))
 
 (define (checker-for-hidden-steps label form attrs)
   (cond [(assq '#:same-hidden-steps attrs)
          (unless (assq '#:steps attrs)
            (error 'checker-for-hidden-steps "no steps given for ~s" label))
+         (delay-test
           (test-case label
             (let* ([d (trace/ns form (assq '#:kernel attrs))]
                    [rs (parameterize ((macro-policy T-policy))
                          (reductions d))])
-             (check-steps (cdr (assq '#:steps attrs)) rs)))]
+              (check-steps (cdr (assq '#:steps attrs)) rs))))]
         [(assq '#:hidden-steps attrs)
          => (lambda (key+expected)
+              (delay-test
                (test-case label
                  (let* ([d (trace/ns form (assq '#:kernel attrs))]
                         [rs (parameterize ((macro-policy T-policy))
                               (reductions d))])
-                  (check-steps (cdr (assq '#:hidden-steps attrs)) rs))))]
+                   (check-steps (cdr (assq '#:hidden-steps attrs)) rs)))))]
         [else #f]))
 
 (define (check-steps expected actual)

collects/tests/macro-debugger/tests/collects.rkt

@@ -1,6 +1,5 @@
 #lang scheme/base
-(require rackunit
+(require rackunit)
-         rackunit/gui)
 (require macro-debugger/model/debug
          scheme/path
          scheme/gui)

collects/tests/macro-debugger/tests/syntax-basic.rkt

@@ -1,4 +1,3 @@
-
 #lang scheme/base
 (require "../gentest-framework.ss")
 (provide proto:kernel-forms
@@ -88,7 +87,7 @@
           #:no-steps)]
 
   [#:suite
-   "Binding forms and blocks"
+   "Binding forms"
    (testK "lambda (simple)"
           (lambda (x) x)
           [#:steps (rename-lambda (lambda (x) x))]
@@ -123,7 +122,50 @@
           #:same-hidden-steps)]
 
   [#:suite
-   "Internal definitions"
+   "Internal definitions within #%stratified-body"
+   (testK "internal begin (empty)"
+          (#%stratified-body (begin) 'a)
+          [#:steps (splice-block (#%stratified-body 'a))
+                   (macro 'a)]
+          [#:hidden-steps (splice-block (#%stratified-body 'a))])
+   (testK "internal begin (solo)"
+          (#%stratified-body (begin 'b))
+          [#:steps (splice-block (#%stratified-body 'b))
+                   (macro 'b)]
+          [#:hidden-steps (splice-block (#%stratified-body 'b))])
+   (testK "internal begin"
+          (#%stratified-body (begin 'a) 'b)
+          [#:steps (splice-block (#%stratified-body 'a 'b))
+                   (macro (begin 'a 'b))]
+          [#:hidden-steps (splice-block (#%stratified-body 'a 'b))])
+   (testK "internal define-values"
+          (#%stratified-body (define-values (x) 'a) 'b)
+          [#:steps (block->letrec (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
+                   (rename-letrec-values (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
+                   (macro (letrec-values ([(x) 'a]) 'b))]
+          [#:hidden-steps (block->letrec (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
+                          (rename-letrec-values (#%stratified-body (letrec-values ([(x) 'a]) 'b)))])
+   (testK "internal define-values in begin"
+          (#%stratified-body (begin (define-values (x) 'a)) 'b)
+          [#:steps
+           (splice-block (#%stratified-body (define-values (x) 'a) 'b))
+           (block->letrec (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
+           (rename-letrec-values (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
+           (macro (letrec-values ([(x) 'a]) 'b))]
+          [#:hidden-steps
+           (splice-block (#%stratified-body (define-values (x) 'a) 'b))
+           (block->letrec (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
+           (rename-letrec-values (#%stratified-body (letrec-values ([(x) 'a]) 'b)))])
+   (testK "internal begin, then define-values"
+          (#%stratified-body (begin) (define-values (x) 'a) 'b)
+          [#:steps
+           (splice-block (#%stratified-body (define-values (x) 'a) 'b))
+           (block->letrec (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
+           (rename-letrec-values (#%stratified-body (letrec-values ([(x) 'a]) 'b)))
+           (macro (letrec-values ([(x) 'a]) 'b))])]
+
+  [#:suite
+   "Internal definitions (mixed defs and exprs)"
    (testK "internal begin (empty)"
           (lambda () (begin) 'a)
           [#:steps (rename-lambda (lambda () (begin) 'a))
@@ -165,6 +207,13 @@
            (splice-block (lambda () (define-values (x) 'a) 'b))
            (block->letrec (lambda () (letrec-values ([(x) 'a]) 'b)))
            (rename-letrec-values (lambda () (letrec-values ([(x) 'a]) 'b)))]
+          #:same-hidden-steps)
+   (testK "define-values after expr"
+          (lambda () 'a (define-values (x) 'b) 'c)
+          [#:steps
+           (rename-lambda (lambda () 'a (define-values (x) 'b) 'c))
+           (block->letrec (lambda () (letrec-values ([() (begin 'a (#%app values))] [(x) 'b]) 'c)))
+           (rename-letrec-values (lambda () (letrec-values ([() (begin 'a (#%app values))] [(x) 'b]) 'c)))]
           #:same-hidden-steps)]
 
   [#:suite

collects/tests/macro-debugger/tests/syntax-errors.rkt

@@ -206,28 +206,27 @@
               (define-values (x) 1)
               (define-values (x) 2)
               3)
-            [#:rename+error-step rename-lambda])
+            [#:rename+error-step rename-lambda])]
-    (testKE (lambda (x)
+   [#:suite
+    "#%stratified-body"
+    (testKE (#%stratified-body
              (define-values (x) 'a)
              'b
              (define-values (y) 'c)
              'd)
-            [#:steps (rename-lambda (lambda (x)
+            [#:steps (block->letrec (#%stratified-body
-                                      (define-values (x) 'a)
-                                      'b
-                                      (define-values (y) 'c)
-                                      'd))
-                     (block->letrec (lambda (x)
                                      (letrec-values ([(x) 'a])
                                        'b
                                        (define-values (y) 'c)
                                        'd)))
-                     (rename-letrec-values (lambda (x)
+                     (rename-letrec-values (#%stratified-body
                                             (letrec-values ([(x) 'a])
                                               'b
                                               (define-values (y) 'c)
                                               'd)))
-                     error])]
+                     error])
+    (testKE (#%stratified-body (define-values (x) 'a))
+            [#:steps error])]
    [#:suite
     "bad internal begin"
     (testKE (lambda () (begin . 1))