www

commit be8ce288fa73a1f91508e3a178227bd2a1644ac7
parent a4731a40e87cae945000eb5efed8fbce6c949a8c
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date:   Sat,  3 Mar 2007 09:08:23 +0000

Macro stepper: improved frontier tracking and macro hiding

svn: r5724

original commit: bb937c80a1437dc598772414491dc886f13b02d8

Diffstat:
M
collects/macro-debugger/model/reductions.ss
 | 
34
+++++++++++++++++++++++++++++-----

1 file changed, 29 insertions(+), 5 deletions(-)
diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss
@@ -166,7 +166,9 @@
           [Block (?body ...) (map cdr renames+bodies)])
        (with-syntax ([(?case-lambda [?formals . ?body] ...) e1]
                      [((?formals* . ?body*) ...) (map car renames+bodies)])
+         (add-frontier (apply append (map stx->list (syntax->list #'(?body ...)))))
          (let ([mid (syntax/skeleton e1 (?case-lambda [?formals* . ?body*] ...))])
+           (rename-frontier #'(?formals ...) #'(?formals* ...))
            (cons (walk/foci (syntax->list #'(?formals ...))
                             (syntax->list #'(?formals* ...))
                             e1 mid 'rename-case-lambda)
@@ -272,6 +274,24 @@
       ;; These have their own subterm replacement mechanisms
       ;; FIXME: Frontier
       [(and d (AnyQ p:synth (e1 e2 rs subterms)))
+       ;; First, compute the frontier based on the expanded subterms
+       ;; Run through the renames in reverse order to get the pre-renamed terms
+       (define synth-frontier
+         (parameterize ((current-frontier null))
+           (let floop ([subterms subterms])
+             (cond [(null? subterms)
+                    (void)]
+                   [(s:subterm? (car subterms))
+                    (floop (cdr subterms))
+                    (add-frontier
+                     (list (lift/deriv-e1 (s:subterm-deriv (car subterms)))))]
+                   [(s:rename? (car subterms))
+                    (floop (cdr subterms))
+                    (rename-frontier (s:rename-after (car subterms))
+                                     (s:rename-before (car subterms)))]))
+           (current-frontier)))
+       (add-frontier synth-frontier)
+       ;; Then compute the reductions
        (let loop ([term e1] [subterms subterms])
          (cond [(null? subterms) 
                 (let ([exn (and (error-wrap? d) (error-wrap-exn d))])
@@ -292,6 +312,8 @@
                 (let* ([subterm0 (car subterms)])
                   ;; FIXME: add renaming steps?
                   ;; FIXME: if so, coalesce?
+                  (rename-frontier (s:rename-before subterm0)
+                                   (s:rename-after subterm0))
                   (loop (path-replace term
                                       (s:rename-path subterm0)
                                       (s:rename-after subterm0))
@@ -299,7 +321,7 @@
 
       ;; FIXME
       [(IntQ p:rename (e1 e2 rs rename inner))
-       ;; FIXME: frontier
+       (rename-frontier (car rename) (cdr rename))
        (reductions* inner)]
 
       ;; Error
@@ -314,11 +336,13 @@
 
       ;; Lifts
 
-      ;; FIXME: frontier
       [(IntQ lift-deriv (e1 e2 first lifted-stx second))
-       (append (reductions* first)
-               (list (walk (deriv-e2 first) lifted-stx 'capture-lifts))
-               (reductions* second))]
+       (blaze-frontier e1)
+       (let ([rs1 (reductions* first)])
+         (add-frontier (list lifted-stx))
+         (append rs1 
+                 (list (walk (deriv-e2 first) lifted-stx 'capture-lifts))
+                 (reductions* second)))]
 
       ;; Skipped