commit f5db71adc2abcdc65f3f9cb43d24d4d7ca696238
parent e9a8f801d30da1aa367951add61abd943b34d597
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Thu, 30 Jun 2011 01:08:29 -0600
macro-stepper: first step to making macro stepper aware of syntax tainting
original commit: 71a92f2957678e5b7c6d45e2510171dc861bc6c3
Diffstat:
5 files changed, 63 insertions(+), 89 deletions(-)
diff --git a/collects/macro-debugger/model/context.rkt b/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)
- (loop (sub1 n) (stx-cdr stx)))))
+ (stx-car* 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)
- (loop (sub1 n) (stx-cdr stx)))))
+ (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)))
diff --git a/collects/macro-debugger/model/reductions-engine.rkt b/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"
diff --git a/collects/macro-debugger/model/reductions.rkt b/collects/macro-debugger/model/reductions.rkt
@@ -1,6 +1,7 @@
#lang racket/base
-(require racket/match
- (for-syntax racket/base)
+(require (for-syntax racket/base)
+ racket/match
+ syntax/stx
"../util/eomap.rkt"
"stx-util.rkt"
"deriv-util.rkt"
diff --git a/collects/macro-debugger/model/stx-util.rkt b/collects/macro-debugger/model/stx-util.rkt
@@ -1,18 +1,22 @@
#lang racket/base
(require (for-syntax racket/base)
syntax/stx)
-
-(provide (all-defined-out)
- (all-from-out syntax/stx))
-
-(define (d->so template datum)
- (if (syntax? template)
- (datum->syntax template datum template template)
- datum))
+(provide stx->datum
+ syntaxish?
+ syntax-copier)
(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)
- (let loop ([i 0])
- (if (< i n)
- (cons i (loop (add1 i)))
- 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)))))
+(define (d->so template datum)
+ (if (syntax? template)
+ (datum->syntax template datum template template)
+ datum))
diff --git a/collects/macro-debugger/syntax-browser/properties.rkt b/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)
