www

commit 3a22aab8af6385f911529747301c9197fa691913
parent 06aad5203aa196a756adbbd2a2620d2cfe245c26
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date:   Sun, 13 Aug 2006 03:28:43 +0000

Merged 4023:4047 from /branches/ryanc/md1
  - Fixed macro hiding for letrec-syntaxes+values
  - Fixed module tracing (prevented required modules from being traced)
  - Better auto-scroll in gui
  - Fixed reductions bug in letrec-syntaxes+values
  - Added hide library syntax option

svn: r4048

original commit: adb230f3c3f6bbd7915c5cebc8797158a209d523

Diffstat:
M
collects/macro-debugger/model/deriv-parser.ss
 | 
2
--
M
collects/macro-debugger/model/hiding-policies.ss
 | 
22
++++++++++++++++++++--
M
collects/macro-debugger/model/reductions.ss
 | 
12
+++++++-----
M
collects/macro-debugger/model/trace.ss
 | 
1
+

4 files changed, 28 insertions(+), 9 deletions(-)
diff --git a/collects/macro-debugger/model/deriv-parser.ss b/collects/macro-debugger/model/deriv-parser.ss
@@ -347,8 +347,6 @@
        [(prim-letrec-values ! renames-let (? NextEEs 'rhss) next-group (? EB 'body))
         (make-p:letrec-values e1 e2 rs $3 $4 $6)])
       
-      ;; Might have to deal with let*-values
-      
       (PrimLetrecSyntaxes+Values
        (#:args e1 e2 rs)
        [(prim-letrec-syntaxes+values (! 'bad-syntax) renames-letrec-syntaxes
diff --git a/collects/macro-debugger/model/hiding-policies.ss b/collects/macro-debugger/model/hiding-policies.ss
@@ -5,17 +5,23 @@
   (provide (all-defined))
 
   (define-struct hiding-policy
-    (opaque-modules opaque-ids opaque-kernel transparent-ids))
+    (opaque-modules opaque-ids opaque-kernel opaque-libs transparent-ids))
 
   (define (policy-hide-module p m)
     (hash-table-put! (hiding-policy-opaque-modules p) m #t))
   (define (policy-unhide-module p m)
     (hash-table-remove! (hiding-policy-opaque-modules p) m))
+
   (define (policy-hide-kernel p)
     (set-hiding-policy-opaque-kernel! p #t))
   (define (policy-unhide-kernel p)
     (set-hiding-policy-opaque-kernel! p #f))
 
+  (define (policy-hide-libs p)
+    (set-hiding-policy-opaque-libs! p #t))
+  (define (policy-unhide-libs p)
+    (set-hiding-policy-opaque-libs! p #f))
+
   (define (policy-hide-id p id)
     (policy-unshow-id p id)
     (module-identifier-mapping-put! (hiding-policy-opaque-ids p) id #t))
@@ -32,11 +38,13 @@
     (make-hiding-policy (make-hash-table)
                         (make-module-identifier-mapping)
                         #f
+                        #f
                         (make-module-identifier-mapping)))
   
   (define (new-standard-hiding-policy)
     (let ([p (new-hiding-policy)])
       (policy-hide-kernel p)
+      (policy-hide-libs p)
       p))
 
   ;; ---
@@ -57,6 +65,7 @@
       [(struct hiding-policy (opaque-modules
                               opaque-identifiers
                               opaque-kernel
+                              opaque-libs
                               transparent-identifiers))
        (let ([binding (identifier-binding id)])
          (if (list? binding)
@@ -67,7 +76,9 @@
                         [in-kernel?
                          (and (symbol? srcmod)
                               (eq? #\# (string-ref (symbol->string srcmod) 0)))]
-                        [not-opaque-id 
+                        [in-lib-module?
+                         (lib-module? srcmod)]
+                        [not-opaque-id
                          (not (module-identifier-mapping-get opaque-identifiers id /false))]
                         [transparent-id
                          (module-identifier-mapping-get transparent-identifiers id /false)])
@@ -75,7 +86,14 @@
                            (and (not opaque-srcmod)
                                 (not opaque-nommod)
                                 (not (and in-kernel? opaque-kernel))
+                                (not (and in-lib-module? opaque-libs))
                                 not-opaque-id))))
              #f))]))
 
+  (define (lib-module? mpi)
+    (and (module-path-index? mpi)
+         (let-values ([(path rel) (module-path-index-split mpi)])
+           (cond [(pair? path) (memq (car path) '(lib planet))]
+                 [(string? path) (lib-module? rel)]
+                 [else #f]))))
   )
 \ No newline at end of file
diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss
@@ -207,11 +207,13 @@
                   (syntax->list #'(?svars* ...))
                   "Rename bound variables"]
           [Expr (?srhs ...) srhss]
-          [#:bind (([?vvars** ?vrhs**] ...) . ?body**) vrenames]
-          [#:walk (syntax/skeleton e1 (?lsv ([?svars* ?srhs*] ...) ([?vars** ?vrhs**] ...) . ?body**))
-                  (syntax->list #'(?vvars* ...))
-                  (syntax->list #'(?vvars** ...))
-                  "Rename bound variables"]
+          ;; If vrenames is #f, no var bindings to rename
+          [#:if vrenames
+                [#:bind (([?vvars** ?vrhs**] ...) . ?body**) vrenames]
+                [#:walk (syntax/skeleton e1 (?lsv ([?svars* ?srhs*] ...) ([?vars** ?vrhs**] ...) . ?body**))
+                        (syntax->list #'(?vvars* ...))
+                        (syntax->list #'(?vvars** ...))
+                        "Rename bound variables"]]
           [Expr (?vrhs ...) vrhss]
           [Block ?body body]
           => (lambda (mid)
diff --git a/collects/macro-debugger/model/trace.ss b/collects/macro-debugger/model/trace.ss
@@ -13,6 +13,7 @@
            trace
            trace/result
            trace+reductions
+           current-expand-observe
            (all-from "reductions.ss"))
 
   (define current-expand-observe