www

commit 690de675dff64b93a2745be00691e0e7cc2fd3fb
parent f5db71adc2abcdc65f3f9cb43d24d4d7ca696238
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date:   Sat,  2 Jul 2011 23:30:40 -0600

macro-stepper: more work on syntax tainting

original commit: 5ec2fee90d562401f91ad7de6759592e71f0630a

Diffstat:
M
collects/macro-debugger/model/context.rkt
 | 
18
++----------------
M
collects/macro-debugger/model/stx-util.rkt
 | 
34
+++++++++++++++++++++++++++++++++-
M
collects/macro-debugger/syntax-browser/pretty-helper.rkt
 | 
7
++++---

3 files changed, 39 insertions(+), 20 deletions(-)
diff --git a/collects/macro-debugger/model/context.rkt b/collects/macro-debugger/model/context.rkt
@@ -1,5 +1,6 @@
 #lang racket/base
-(require syntax/stx)
+(require syntax/stx
+         "stx-util.rkt")
 (provide (struct-out ref)
          (struct-out tail)
          path-get
@@ -7,21 +8,6 @@
          path-replace
          pathseg-replace)
 
-;; Update for syntax taint: On get, disarm stx on the way, but don't
-;; disarm final stx. On replace, disarm and rearm along the way.
-
-(define (stx-disarm stx)
-  (if (syntax? stx) (syntax-disarm stx (current-code-inspector)) stx))
-
-(define (stx-car* stx)
-  (let ([stx (stx-disarm stx)]) (stx-car stx)))
-
-(define (stx-cdr* stx)
-  (let ([stx (stx-disarm stx)]) (stx-cdr stx)))
-
-(define (syntax-e* stx)
-  (syntax-e (stx-disarm stx)))
-
 ;; A Path is a (list-of PathSeg)
 ;; where the PathSegs are listed outermost to innermost
 ;; for example: (path-get #'((a b) (c d)) (list (make-ref 0) (make-ref 1))) = #'b, not #'c
diff --git a/collects/macro-debugger/model/stx-util.rkt b/collects/macro-debugger/model/stx-util.rkt
@@ -1,10 +1,42 @@
 #lang racket/base
 (require (for-syntax racket/base)
          syntax/stx)
-(provide stx->datum
+(provide stx-disarm
+         stx-car*
+         stx-cdr*
+         syntax-e*
+         stx->list*
+         stx->datum
          syntaxish?
          syntax-copier)
 
+;; Update for syntax taint: On get, disarm stx on the way, but don't
+;; disarm final stx. On replace, disarm and rearm along the way.
+
+(define (stx-disarm stx)
+  (if (syntax? stx) (syntax-disarm stx (current-code-inspector)) stx))
+
+(define (stx-car* stx)
+  (let ([stx (stx-disarm stx)]) (stx-car stx)))
+
+(define (stx-cdr* stx)
+  (let ([stx (stx-disarm stx)]) (stx-cdr stx)))
+
+(define (syntax-e* stx)
+  (syntax-e (stx-disarm stx)))
+
+(define (stx->list* stx)
+  (if (stx-list? stx)
+      (let loop ([stx stx])
+        (cond [(syntax? stx)
+               (loop (syntax-e* stx))]
+              [(pair? stx)
+               (cons (car stx) (loop (cdr stx)))]
+              [else stx]))
+      #f))
+
+;; ----
+
 (define (stx->datum x)
   (syntax->datum (datum->syntax #f x)))
 
diff --git a/collects/macro-debugger/syntax-browser/pretty-helper.rkt b/collects/macro-debugger/syntax-browser/pretty-helper.rkt
@@ -3,7 +3,8 @@
          unstable/class-iop
          syntax/stx
          unstable/struct
-         "interfaces.rkt")
+         "interfaces.rkt"
+         "../model/stx-util.rkt")
 (provide (all-defined-out))
 
 ;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it
@@ -100,7 +101,7 @@
                       lp-datum))]
               [(syntax? obj)
                (when partition (send/i partition partition<%> get-partition obj))
-               (let ([lp-datum (loop (syntax-e obj))])
+               (let ([lp-datum (loop (syntax-e* obj))])
                  (hash-set! flat=>stx lp-datum obj)
                  (hash-set! stx=>flat obj lp-datum)
                  lp-datum)]
@@ -151,7 +152,7 @@
 
 ;; check+convert-special-expression : syntax -> #f/syntaxish
 (define (check+convert-special-expression stx)
-  (define stx-list (stx->list stx))
+  (define stx-list (stx->list* stx))
   (and stx-list (= 2 (length stx-list))
        (let ([kw (car stx-list)]
              [expr (cadr stx-list)])