Fixed macro-stepper to work with #%top-interaction

svn: r5268

original commit: 7d0d3da0dca00e735db4653f7f84f7f223f0641c

collects/macro-debugger/model/debug.ss

@@ -12,93 +12,5 @@
            (all-from "deriv-util.ss")
            (all-from "hiding-policies.ss")
            (all-from "hide.ss")
-           (all-from (lib "plt-match.ss"))
+           (all-from (lib "plt-match.ss")))
-           find-deriv)
-
-  (define (find-deriv pred d)
-    (define (loop d)
-      (match d
-        [(? pred d) (list d)]
-        [(AnyQ mrule (_ _ tx next))
-         (append (loop tx) (loop next))]
-        [(AnyQ lift-deriv (_ _ first lift second))
-         (append (loop first) (loop lift) (loop second))]
-        [(AnyQ transformation (_ _ _ _ _ locals))
-         (loops locals)]
-        [(struct local-expansion (_ _ _ _ deriv))
-         (loop deriv)]
-        [(struct local-bind (deriv))
-         (loop deriv)]
-        [(AnyQ p:define-syntaxes (_ _ _ rhs))
-         (loop rhs)]
-        [(AnyQ p:define-values (_ _ _ rhs))
-         (loop rhs)]
-        [(AnyQ p:if (_ _ _ _ test then else))
-         (append (loop test) (loop then) (loop else))]
-        [(AnyQ p:wcm (_ _ _ key value body))
-         (append (loop key) (loop value) (loop body))]
-        [(AnyQ p:set! (_ _ _ _ rhs))
-         (loop rhs)]
-        [(AnyQ p:set!-macro (_ _ _ deriv))
-         (loop deriv)]
-        [(AnyQ p:begin (_ _ _ lderiv))
-         (loop lderiv)]
-        [(AnyQ p:begin0 (_ _ _ first lderiv))
-         (append (loop first) (loop lderiv))]
-        [(AnyQ p:#%app (_ _ _ _ lderiv))
-         (loop lderiv)]
-        [(AnyQ p:lambda (_ _ _ _ body))
-         (loop body)]
-        [(AnyQ p:case-lambda (_ _ _ rbs))
-         (apply append (map loop (map cdr (or rbs null))))]
-        [(AnyQ p:let-values (_ _ _ _ rhss body))
-         (append (loops rhss) (loop body))]
-        [(AnyQ p:letrec-values (_ _ _ _ rhss body))
-         (append (loops rhss) (loop body))]
-        [(AnyQ p:letrec-syntaxes+values (_ _ _ _ srhss _ vrhss body))
-         (append (loops srhss) (loops vrhss) (loop body))]
-        [(AnyQ p:module (_ _ _ _ body))
-         (loop body)]
-        [(AnyQ p:#%module-begin (_ _ _ pass1 pass2))
-         (append (loops pass1) (loops pass2))]
-        [(AnyQ p:rename (_ _ _ _ inner))
-         (loop inner)]
-        [(AnyQ p:synth (_ _ _ subterms))
-         (loops (map s:subterm-deriv subterms))]
-
-        [(AnyQ lderiv (_ _ derivs))
-         (loops derivs)]
-        [(AnyQ bderiv (_ _ pass1 _ pass2))
-         (append (loops pass1) (loop pass2))]
-        [(AnyQ b:defvals (_ head))
-         (loop head)]
-        [(AnyQ b:defstx (_ deriv rhs))
-         (append (loop deriv) (loop rhs))]
-        [(AnyQ b:splice (_ head _))
-         (loop head)]
-        [(AnyQ b:expr (_ head))
-         (loop head)]
-        [(AnyQ b:begin (_ head inner))
-         (append (loop head) (loop inner))]
-        [(AnyQ mod:cons (head))
-         (loop head)]
-        [(AnyQ mod:prim (head prim))
-         (append (loop head) (loop prim))]
-        [(AnyQ mod:splice (head _))
-         (loop head)]
-        [(AnyQ mod:lift (head tail))
-         (append (loop head) (loop tail))]
-        [(AnyQ mod:lift-end (tail))
-         (loop tail)]
-        [(AnyQ mod:begin (head inner))
-         (append (loop head) (loop inner))]
-
-        [else null]))
-
-    (define (loops ds)
-      (if (list? ds)
-          (apply append (map loop ds))
-          null))
-
-    (loop d))
   )

collects/macro-debugger/model/deriv-util.ss

@@ -17,7 +17,11 @@
            outer-rewrap
            lift/deriv-e1
            lift/deriv-e2
-           wrapped?)
+           wrapped?
+
+           find-derivs
+           find-deriv
+           find-derivs/syntax)
 
   ;; IntW
   ;; Matches only interrupted wraps
@@ -161,5 +165,116 @@
 ;         #'($$ S (var ...) (cons #f tag))]
 ;        [($$E S (var ...) @ tag exn)
 ;         #'($$ S (var ...) (cons exn tag))])))
+
+  ;; Utilities for finding subderivations
   
+  ;; find-derivs : (deriv -> boolean) (deriv -> boolean) deriv -> (list-of deriv)
+  (define (find-derivs pred stop-short d)
+    (find-deriv/unit+join+zero pred stop-short d list append null))
+
+  ;; find-deriv : (deriv -> boolean) (deriv -> boolean) deriv -> deriv/#f
+  ;; Finds the first deriv that matches; throws the rest away
+  (define (find-deriv pred stop-short d)
+    (let/ec return (find-deriv/unit+join+zero pred stop-short d return (lambda _ #f) #f)))
+
+  ;; find-deriv/unit+join+zero
+  ;; Parameterized over monad operations for combining the results
+  ;; For example, <list, append, null> collects the results into a list
+  (define (find-deriv/unit+join+zero pred stop-short d unit join zero)
+    (define (loop d)
+      (match d
+        [(? pred d) (unit d)]
+        [(? stop-short d) zero]
+        [(AnyQ mrule (_ _ tx next))
+         (join (loop tx) (loop next))]
+        [(AnyQ lift-deriv (_ _ first lift second))
+         (join (loop first) (loop lift) (loop second))]
+        [(AnyQ transformation (_ _ _ _ _ locals))
+         (loops locals)]
+        [(struct local-expansion (_ _ _ _ deriv))
+         (loop deriv)]
+        [(struct local-bind (deriv))
+         (loop deriv)]
+        [(AnyQ p:define-syntaxes (_ _ _ rhs))
+         (loop rhs)]
+        [(AnyQ p:define-values (_ _ _ rhs))
+         (loop rhs)]
+        [(AnyQ p:if (_ _ _ _ test then else))
+         (join (loop test) (loop then) (loop else))]
+        [(AnyQ p:wcm (_ _ _ key value body))
+         (join (loop key) (loop value) (loop body))]
+        [(AnyQ p:set! (_ _ _ _ rhs))
+         (loop rhs)]
+        [(AnyQ p:set!-macro (_ _ _ deriv))
+         (loop deriv)]
+        [(AnyQ p:begin (_ _ _ lderiv))
+         (loop lderiv)]
+        [(AnyQ p:begin0 (_ _ _ first lderiv))
+         (join (loop first) (loop lderiv))]
+        [(AnyQ p:#%app (_ _ _ _ lderiv))
+         (loop lderiv)]
+        [(AnyQ p:lambda (_ _ _ _ body))
+         (loop body)]
+        [(AnyQ p:case-lambda (_ _ _ rbs))
+         (apply join (map loop (map cdr (or rbs null))))]
+        [(AnyQ p:let-values (_ _ _ _ rhss body))
+         (join (loops rhss) (loop body))]
+        [(AnyQ p:letrec-values (_ _ _ _ rhss body))
+         (join (loops rhss) (loop body))]
+        [(AnyQ p:letrec-syntaxes+values (_ _ _ _ srhss _ vrhss body))
+         (join (loops srhss) (loops vrhss) (loop body))]
+        [(AnyQ p:module (_ _ _ _ body))
+         (loop body)]
+        [(AnyQ p:#%module-begin (_ _ _ pass1 pass2))
+         (join (loops pass1) (loops pass2))]
+        [(AnyQ p:rename (_ _ _ _ inner))
+         (loop inner)]
+        [(AnyQ p:synth (_ _ _ subterms))
+         (loops (map s:subterm-deriv subterms))]
+
+        [(AnyQ lderiv (_ _ derivs))
+         (loops derivs)]
+        [(AnyQ bderiv (_ _ pass1 _ pass2))
+         (join (loops pass1) (loop pass2))]
+        [(AnyQ b:defvals (_ head))
+         (loop head)]
+        [(AnyQ b:defstx (_ deriv rhs))
+         (join (loop deriv) (loop rhs))]
+        [(AnyQ b:splice (_ head _))
+         (loop head)]
+        [(AnyQ b:expr (_ head))
+         (loop head)]
+        [(AnyQ b:begin (_ head inner))
+         (join (loop head) (loop inner))]
+        [(AnyQ mod:cons (head))
+         (loop head)]
+        [(AnyQ mod:prim (head prim))
+         (join (loop head) (loop prim))]
+        [(AnyQ mod:splice (head _))
+         (loop head)]
+        [(AnyQ mod:lift (head tail))
+         (join (loop head) (loop tail))]
+        [(AnyQ mod:lift-end (tail))
+         (loop tail)]
+        [(AnyQ mod:begin (head inner))
+         (join (loop head) (loop inner))]
+
+        [else zero]))
+
+    (define (loops ds)
+      (if (list? ds)
+          (apply join (map loop ds))
+          zero))
+    (loop d))
+
+  (define (find-derivs/syntax pred d)
+    (find-derivs (match-lambda
+                  [(AnyQ deriv (e1 e2))
+                   (pred e1)]
+                  [_ #f])
+                 (match-lambda
+                  [(AnyQ p:module (_ _ _ _ _)) #t]
+                  [(AnyQ lift-deriv (_ _ _ _ _)) #t]
+                  [_ #f])
+                 d))
   )