diff --git a/collects/macro-debugger/model/context.rkt b/collects/macro-debugger/model/context.rkt index 39fd66b..632f346 100644 --- 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 index 8e2f855..af7b9a2 100644 --- 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 index a67ebc2..81edd06 100644 --- 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)])