From 44672c7c5dfb3611778581eca8b421745bc30946 Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Tue, 13 Jul 2010 10:53:04 -0600
Subject: [PATCH] macro-stepper: better internal debugging

original commit: cb62eeffb6cacf0a8488176804fe722544bb5e73
---
 .../model/reductions-engine.rkt               | 47 ++++++++++---------
 collects/macro-debugger/model/steps.rkt       |  3 +-
 2 files changed, 27 insertions(+), 23 deletions(-)

diff --git a/collects/macro-debugger/model/reductions-engine.rkt b/collects/macro-debugger/model/reductions-engine.rkt
index 5970a70..afdd9cf 100644
--- a/collects/macro-debugger/model/reductions-engine.rkt
+++ b/collects/macro-debugger/model/reductions-engine.rkt
@@ -150,7 +150,7 @@
                       (current-state-with v (with-syntax1 ([p f]) fs)))]
              [type-var type])
          (DEBUG
-          (printf "visibility = ~s\n" (visibility))
+          (printf "visibility = ~s\n" (if (visibility) 'VISIBLE 'HIDDEN))
           (printf "step: s1 = ~s\n" s)
           (printf "step: s2 = ~s\n\n" s2))
          (let ([ws2
@@ -324,7 +324,7 @@
          (visibility-off (not previous-pass-hides?)
                          v
                          (lambda ()
-                           (print-viable-subterms v)
+                           (when #f (print-viable-subterms v))
                            (R** f v p s ws clause ... => k))
                          #t))]
 
@@ -495,26 +495,29 @@
 (define (seek-point stx vstx k)
   (if (visibility)
       (k vstx)
-      (let ([paths (table-get (subterms-table) stx)])
-        (cond [(null? paths)
-               (DEBUG (printf "seek-point: failed on ~.s\n" (stx->datum stx)))
-               (k vstx)]
-              [(null? (cdr paths))
-               (let ([path (car paths)])
-                 (DEBUG (printf "seek => hide: ~.s\n" (stx->datum stx)))
-                 (let ([ctx (lambda (x) (path-replace vstx path x))])
-                   (RScase (parameterize ((visibility #t)
-                                          (subterms-table #f)
-                                          (marking-table #f))
-                             ;; Found stx within vstx
-                             (with-context ctx (k stx)))
-                           (lambda (ws2 stx2 vstx2 s2)
-                             (let ([vstx2 (ctx vstx2)])
-                               (RSunit ws2 stx2 vstx2 s2)))
-                           (lambda (ws exn)
-                             (RSfail ws exn)))))]
-              [else
-               (raise (make nonlinearity stx paths))]))))
+      (begin
+        (DEBUG (printf "Seek point\n")
+               (print-viable-subterms stx))
+        (let ([paths (table-get (subterms-table) stx)])
+          (cond [(null? paths)
+                 (DEBUG (printf "seek-point: failed on ~.s\n" (stx->datum stx)))
+                 (k vstx)]
+                [(null? (cdr paths))
+                 (let ([path (car paths)])
+                   (DEBUG (printf "seek => hide: ~.s\n" (stx->datum stx)))
+                   (let ([ctx (lambda (x) (path-replace vstx path x))])
+                     (RScase (parameterize ((visibility #t)
+                                            (subterms-table #f)
+                                            (marking-table #f))
+                               ;; Found stx within vstx
+                               (with-context ctx (k stx)))
+                             (lambda (ws2 stx2 vstx2 s2)
+                               (let ([vstx2 (ctx vstx2)])
+                                 (RSunit ws2 stx2 vstx2 s2)))
+                             (lambda (ws exn)
+                               (RSfail ws exn)))))]
+                [else
+                 (raise (make nonlinearity stx paths))])))))
 
 (provide print-viable-subterms)
 (define (print-viable-subterms stx)
diff --git a/collects/macro-debugger/model/steps.rkt b/collects/macro-debugger/model/steps.rkt
index e7e8184..e27789b 100644
--- a/collects/macro-debugger/model/steps.rkt
+++ b/collects/macro-debugger/model/steps.rkt
@@ -112,7 +112,8 @@
           rename-case-lambda
           rename-let-values
           rename-letrec-values
-          rename-lsv)))
+          rename-lsv
+          track-origin)))
 
 (define (rewrite-step? x)
   (and (step? x) (not (rename-step? x))))