macro-stepper: first step to making macro stepper aware of syntax tainting

collects/macro-debugger/model/context.rkt

@@ -7,6 +7,21 @@
          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
@@ -19,13 +34,6 @@
 (define-struct (ref pathseg) (n) #:transparent)
 (define-struct (tail pathseg) (n) #:transparent)
 
-;; path:ref->splicing-tail : PathSeg -> ???
-;; ????
-(define (path:ref->splicing-tail path)
-  (unless (ref? path)
-    (raise-type-error 'path:ref->splicing-tail "ref path" path))
-  (make-tail (sub1 (ref-n path))))
-
 ;; path-get : syntax Path -> syntax
 (define (path-get stx path)
   (let loop ([stx stx] [path path])
@@ -48,8 +56,8 @@
              n0
              (syntax->datum stx0)))
     (if (zero? n)
-        (stx-car stx)
+        (stx-car* stx)
-        (loop (sub1 n) (stx-cdr stx)))))
+        (loop (sub1 n) (stx-cdr* stx)))))
 
 ;; pathseg-get/tail : syntax number -> syntax
 (define (pathseg-get/tail stx0 n0)
@@ -57,8 +65,8 @@
     (unless (stx-pair? stx)
       (error 'pathseg-get "tail path out of bounds for syntax: ~s, ~s" n0 stx0))
     (if (zero? n)
-        (stx-cdr stx)
+        (stx-cdr* stx)
-        (loop (sub1 n) (stx-cdr stx)))))
+        (loop (sub1 n) (stx-cdr* stx)))))
 
 ;; path-replace : syntax Path syntax -> syntax
 (define (path-replace stx path x)
@@ -86,7 +94,7 @@
       (error 'pathseg-replace "ref path out of bounds for syntax: ~s, ~s" n0 stx0))
     (if (zero? n)
         (stx-replcar stx x)
-        (stx-replcdr stx (loop (sub1 n) (stx-cdr stx))))))
+        (stx-replcdr stx (loop (sub1 n) (stx-cdr* stx))))))
 
 ;; pathseg-replace/tail : syntax number syntax -> syntax
 (define (pathseg-replace/tail stx0 n0 x)
@@ -95,14 +103,16 @@
       (error 'pathseg-replace "tail path out of bounds for syntax: ~s, ~s" n0 stx0))
     (if (zero? n)
         (stx-replcdr stx x)
-        (stx-replcdr stx (loop (sub1 n) (stx-cdr stx))))))
+        (stx-replcdr stx (loop (sub1 n) (stx-cdr* stx))))))
 
 ;; stx-replcar : syntax syntax -> syntax
 (define (stx-replcar stx x)
   (cond [(pair? stx)
          (cons x (cdr stx))]
         [(syntax? stx)
-         (datum->syntax stx (cons x (cdr (syntax-e stx))) stx stx)]
+         (syntax-rearm
+          (datum->syntax stx (cons x (cdr (syntax-e stx))) stx stx)
+          stx)]
         [else (raise-type-error 'stx-replcar "stx-pair" stx)]))
 
 ;; stx-replcdr : syntax syntax -> syntax
@@ -110,8 +120,7 @@
   (cond [(pair? stx)
          (cons (car stx) x)]
         [(and (syntax? stx) (pair? (syntax-e stx)))
-         (datum->syntax stx (cons (car (syntax-e stx)) x) stx stx)]
+         (syntax-rearm
+          (datum->syntax stx (cons (car (syntax-e stx)) x) stx stx)
+          stx)]
         [else (raise-type-error 'stx-replcdr "stx-pair" stx)]))
-
-(define (sd x)
-  (syntax->datum (datum->syntax #f x)))

collects/macro-debugger/model/reductions-engine.rkt

@@ -3,6 +3,7 @@
                      syntax/parse
                      syntax/parse/experimental/contract)
          racket/contract
+         syntax/stx
          "deriv-util.rkt"
          "stx-util.rkt"
          "context.rkt"

collects/macro-debugger/model/reductions.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
-(require racket/match
+(require (for-syntax racket/base)
-         (for-syntax racket/base)
+         racket/match
+         syntax/stx
          "../util/eomap.rkt"
          "stx-util.rkt"
          "deriv-util.rkt"

collects/macro-debugger/model/stx-util.rkt

@@ -1,18 +1,22 @@
 #lang racket/base
 (require (for-syntax racket/base)
          syntax/stx)
-
+(provide stx->datum
-(provide (all-defined-out)
+         syntaxish?
-         (all-from-out syntax/stx))
+         syntax-copier)
-
-(define (d->so template datum)
-  (if (syntax? template)
-      (datum->syntax template datum template template)
-      datum))
 
 (define (stx->datum x)
   (syntax->datum (datum->syntax #f x)))
 
+(define (syntaxish? x)
+  (or (syntax? x)
+      (null? x)
+      (and (pair? x)
+           (syntaxish? (car x))
+           (syntaxish? (cdr x)))))
+
+;; ----
+
 (define-syntax (syntax-copier stx)
   (syntax-case stx ()
     [(syntax-copier hole expr pattern)
@@ -27,7 +31,6 @@
     [(syntax/skeleton old-expr pattern)
      (syntax/restamp pattern #'pattern old-expr)]))
 
-
 ;; FIXME: Need to avoid turning syntax lists into syntax pairs
 (define-syntax (syntax/restamp stx)
   (syntax-case stx (...)
@@ -63,61 +66,7 @@
     [(syntax/restamp pvar new-expr old-expr)
      #'new-expr]))
 
-(define (iota n)
+(define (d->so template datum)
-  (let loop ([i 0])
+  (if (syntax? template)
-    (if (< i n)
+      (datum->syntax template datum template template)
-        (cons i (loop (add1 i)))
+      datum))
-        null)))
-
-;; stx-take : syntax-list number -> (list-of syntax)
-(define (stx-take items n)
-  (cond [(zero? n) null]
-        [else (cons (stx-car items) (stx-take (stx-cdr items) (sub1 n)))]))
-
-(define (take-if-possible items n)
-  (unless (number? n)
-    (raise-type-error 'take-if-possible "number" n))
-  (if (and (pair? items) (positive? n))
-      (cons (car items) (take-if-possible (cdr items) (sub1 n)))
-      null))
-
-(define (reverse-take-if-possible items n)
-  (define (loop items n acc)
-    (if (and (pair? items) (positive? n))
-        (loop (cdr items) (sub1 n) (cons (car items) acc))
-        acc))
-  (loop items n null))
-
-(define (reverse-take-until items tail)
-  (define (loop items acc)
-    (if (and (pair? items) (not (eq? items tail)))
-        (loop (cdr items) (cons (car items) acc))
-        null))
-  (loop items null))
-
-;; stx-improper-length : syntax -> number
-(define (stx-improper-length stx)
-  (let loop ([stx stx] [n 0])
-    (if (stx-pair? stx)
-        (loop (stx-cdr stx) (add1 n))
-        n)))
-
-(define (stx->list* stx)
-  (cond [(pair? stx)
-         (cons (car stx) (stx->list* (cdr stx)))]
-        [(null? stx)
-         null]
-        [(syntax? stx)
-         (let ([x (syntax-e stx)])
-           (if (pair? x)
-               (cons (car x) (stx->list* (cdr x)))
-               (list stx)))]
-        [else null]))
-
-
-(define (syntaxish? x)
-  (or (syntax? x)
-      (null? x)
-      (and (pair? x)
-           (syntaxish? (car x))
-           (syntaxish? (cdr x)))))

collects/macro-debugger/syntax-browser/properties.rkt

@@ -202,7 +202,8 @@
       (display-source-info stx)
       (display-extra-source-info stx)
       (display-symbol-property-info stx)
-      (display-marks stx))
+      (display-marks stx)
+      (display-taint stx))
 
     ;; display-source-info : syntax -> void
     (define/private (display-source-info stx)
@@ -246,7 +247,20 @@
     ;; display-marks : syntax -> void
     (define/private (display-marks stx)
       (display "Marks: " key-sd)
-      (display (format "~s\n" (simplify-marks (get-marks stx))) #f))
+      (display (format "~s\n" (simplify-marks (get-marks stx))) #f)
+      (display "\n" #f))
+
+    ;; display-taint : syntax -> void
+    (define/private (display-taint stx)
+      (define (syntax-armed? stx)
+        (syntax-tainted? (datum->syntax stx 'dummy)))
+      (display "Tamper status: " key-sd)
+      (display (cond [(syntax-tainted? stx)
+                      "tainted"]
+                     [(syntax-armed? stx)
+                      "armed"]
+                     [else "clean"])
+               #f))
 
     ;; display-kv : any any -> void
     (define/private (display-kv key value)