From b6e46fabb6196062c0bd18b12d8b3857390f8bba Mon Sep 17 00:00:00 2001
From: Ryan Culpepper <ryanc@racket-lang.org>
Date: Fri, 21 Sep 2007 21:03:50 +0000
Subject: [PATCH] Macro stepper: fixed bugs and added new binding info (#%app,
 #%top, #%datum)

svn: r7395

original commit: 3f7ef884163ab94b86b34b571486d6646538f0b4
---
 .../syntax-browser/partition.ss               |  2 +-
 .../syntax-browser/properties.ss              | 20 ++++++++++++++++++-
 .../macro-debugger/syntax-browser/util.ss     | 19 +++++++++---------
 collects/macro-debugger/view/frame.ss         |  4 +---
 4 files changed, 31 insertions(+), 14 deletions(-)

diff --git a/collects/macro-debugger/syntax-browser/partition.ss b/collects/macro-debugger/syntax-browser/partition.ss
index 3adc7e4..cafd426 100644
--- a/collects/macro-debugger/syntax-browser/partition.ss
+++ b/collects/macro-debugger/syntax-browser/partition.ss
@@ -28,7 +28,7 @@
     (class* object% (partition<%>)
       (init relation)
 
-      (define related? relation)
+      (define related? (or relation (lambda (a b) #f)))
       (field (rep=>num (make-hash-table)))
       (field (obj=>rep (make-hash-table 'weak)))
       (field (reps null))
diff --git a/collects/macro-debugger/syntax-browser/properties.ss b/collects/macro-debugger/syntax-browser/properties.ss
index 8969fd7..ba68b2c 100644
--- a/collects/macro-debugger/syntax-browser/properties.ss
+++ b/collects/macro-debugger/syntax-browser/properties.ss
@@ -138,11 +138,29 @@
         (when (and (identifier? stx)
                    (uninterned? (syntax-e stx)))
           (display "Uninterned symbol!\n\n" key-sd))
-        (display-binding-info stx))
+        (display-binding-info stx)
+        (display-indirect-binding-info stx))
 
       ;; display-binding-info : syntax -> void
       (define/private (display-binding-info stx)
         (display "Apparent identifier binding\n" key-sd)
+        (display-bindings stx))
+
+      ;; display-indirect-binding-info : syntax -> void
+      (define/private (display-indirect-binding-info stx)
+        (cond
+         [(identifier? stx)
+          (display "Binding if used for #%top\n" key-sd)
+          (display-bindings (datum->syntax-object stx '#%top))]
+         [(and (syntax? stx) (pair? (syntax-e stx)))
+          (display "Binding if used for #%app\n" key-sd)
+          (display-bindings (datum->syntax-object stx '#%app))]
+         [else
+          (display "Binding if used for #%datum\n" key-sd)
+          (display-bindings (datum->syntax-object stx '#%datum))]))
+
+      ;; display-bindings : syntax -> void
+      (define/private (display-bindings stx)
         (unless (identifier? stx)
           (display "Not applicable\n\n" n/a-sd))
         (when (identifier? stx)
diff --git a/collects/macro-debugger/syntax-browser/util.ss b/collects/macro-debugger/syntax-browser/util.ss
index 1217a2e..bc7a71d 100644
--- a/collects/macro-debugger/syntax-browser/util.ss
+++ b/collects/macro-debugger/syntax-browser/util.ss
@@ -47,13 +47,14 @@
 
   ;; mpi->list : module-path-index -> (list-of module-spec)
   (define (mpi->list mpi)
-    (if mpi
-        (let-values ([(path rel) (module-path-index-split mpi)])
-          (cond [(and (pair? path) (memq (car path) '(file lib planet)))
-                 (cons path null)]
-                [path
-                 (cons path (mpi->list rel))]
-                [else '()]))
-        '()))
-
+    (cond [(module-path-index? mpi)
+           (let-values ([(path rel) (module-path-index-split mpi)])
+             (cond [(and (pair? path) (memq (car path) '(file lib planet)))
+                    (cons path null)]
+                   [path
+                    (cons path (mpi->list rel))]
+                   [else '()]))]
+          [(not mpi)
+           '()]
+          [else (list mpi)]))
   )
diff --git a/collects/macro-debugger/view/frame.ss b/collects/macro-debugger/view/frame.ss
index d8a7644..b4c12fb 100644
--- a/collects/macro-debugger/view/frame.ss
+++ b/collects/macro-debugger/view/frame.ss
@@ -130,9 +130,7 @@
                                 (callback
                                  (lambda _ 
                                    (send (send widget get-controller)
-                                         on-update-identifier=?
-                                         (car p)
-                                         (cdr p)))))])
+                                         set-identifier=? p))))])
                       (send (send widget get-controller)
                             listen-identifier=?
                             (lambda (name+func)