stx-util.rkt (3249B)
1 #lang racket/base 2 (require (for-syntax racket/base) 3 syntax/stx) 4 (provide stx-disarm 5 stx-car* 6 stx-cdr* 7 syntax-e* 8 stx->list* 9 stx->datum 10 syntaxish? 11 syntax-copier) 12 13 ;; Update for syntax taint: On get, disarm stx on the way, but don't 14 ;; disarm final stx. On replace, disarm and rearm along the way. 15 16 (define (stx-disarm stx) 17 (if (syntax? stx) (syntax-disarm stx (current-code-inspector)) stx)) 18 19 (define (stx-car* stx) 20 (let ([stx (stx-disarm stx)]) (stx-car stx))) 21 22 (define (stx-cdr* stx) 23 (let ([stx (stx-disarm stx)]) (stx-cdr stx))) 24 25 (define (syntax-e* stx) 26 (syntax-e (stx-disarm stx))) 27 28 (define (stx->list* stx) 29 (if (stx-list? stx) 30 (let loop ([stx stx]) 31 (cond [(syntax? stx) 32 (loop (syntax-e* stx))] 33 [(pair? stx) 34 (cons (car stx) (loop (cdr stx)))] 35 [else stx])) 36 #f)) 37 38 ;; ---- 39 40 (define (stx->datum x) 41 (syntax->datum (datum->syntax #f x))) 42 43 (define (syntaxish? x) 44 (or (syntax? x) 45 (null? x) 46 (and (pair? x) 47 (syntaxish? (car x)) 48 (syntaxish? (cdr x))))) 49 50 ;; ---- 51 52 (define-syntax (syntax-copier stx) 53 (syntax-case stx () 54 [(syntax-copier hole expr pattern) 55 #'(let ([expr-var expr]) 56 (lambda (in-the-hole) 57 (with-syntax ([pattern expr-var]) 58 (with-syntax ([hole in-the-hole]) 59 (syntax/restamp pattern #'pattern expr-var)))))])) 60 61 (define-syntax syntax/skeleton 62 (syntax-rules () 63 [(syntax/skeleton old-expr pattern) 64 (syntax/restamp pattern #'pattern old-expr)])) 65 66 ;; FIXME: Need to avoid turning syntax lists into syntax pairs 67 (define-syntax (syntax/restamp stx) 68 (syntax-case stx (...) 69 [(syntax/restamp (pa (... ...)) new-expr old-expr) 70 #`(let ([new-parts (stx->list new-expr)] 71 [old-parts (stx->list old-expr)]) 72 ;; FIXME 73 (unless (= (length new-parts) (length old-parts)) 74 (printf "** syntax/restamp\n~s\n" (quote-syntax #,stx)) 75 (printf "pattern : ~s\n" (syntax->datum #'(pa (... ...)))) 76 (printf "old parts: ~s\n" (map syntax->datum old-parts)) 77 (printf "new parts: ~s\n" (map syntax->datum new-parts))) 78 (d->so 79 old-expr 80 (map (lambda (new old) (syntax/restamp pa new old)) 81 new-parts 82 old-parts)))] 83 [(syntax/restamp (pa . pb) new-expr old-expr) 84 ;; FIXME 85 #'(begin 86 (unless (and (stx-pair? new-expr) (stx-pair? old-expr)) 87 (printf "** syntax/restamp\n~s\n" (quote-syntax #,stx)) 88 (printf "pattern : ~s\n" (syntax->datum (quote-syntax (pa . pb)))) 89 (printf "old parts: ~s\n" old-expr) 90 (printf "new parts: ~s\n" new-expr)) 91 (let ([na (stx-car new-expr)] 92 [nb (stx-cdr new-expr)] 93 [oa (stx-car old-expr)] 94 [ob (stx-cdr old-expr)]) 95 (d->so old-expr 96 (cons (syntax/restamp pa na oa) 97 (syntax/restamp pb nb ob)))))] 98 [(syntax/restamp pvar new-expr old-expr) 99 #'new-expr])) 100 101 (define (d->so template datum) 102 (if (syntax? template) 103 (datum->syntax template datum template template) 104 datum))