diff --git a/collects/macro-debugger/model/context.rkt b/collects/macro-debugger/model/context.rkt index 8d6073d..39fd66b 100644 --- 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 index 125b1db..3aec5cd 100644 --- 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 index 2eb58fb..a6c104e 100644 --- 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 index 5114379..8e2f855 100644 --- 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 index 2bf64f1..fde507e 100644 --- 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)