commit bf64dc78e32ca39edbd4687a46f21f668f9aff11
parent 60ab3ffe85773a597bb90ff429f4cf62599ea899
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Mon, 8 Jan 2007 22:16:35 +0000
Fixed macro-stepper to work with #%top-interaction
svn: r5268
original commit: 7d0d3da0dca00e735db4653f7f84f7f223f0641c
Diffstat:
2 files changed, 117 insertions(+), 90 deletions(-)
diff --git a/collects/macro-debugger/model/debug.ss b/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"))
- 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))
+ (all-from (lib "plt-match.ss")))
)
diff --git a/collects/macro-debugger/model/deriv-util.ss b/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))
)
