main.rkt (4402B)
1 #lang racket/base 2 3 (require racket/match 4 syntax/parse 5 (for-syntax racket/base 6 racket/syntax 7 racket/list 8 racket/struct 9 syntax/parse 10 racket/private/sc) 11 ;; attribute-mapping? is provided for-syntax 12 (only-in syntax/parse/private/residual attribute-mapping?)) 13 14 (provide auto-with-syntax) 15 (provide auto-syntax) 16 (provide auto-syntax-case) 17 (module+ utils 18 (provide (for-syntax make-auto-pvar 19 auto-pvar?))) 20 21 (define (leaves->datum e depth) 22 (if (eq? e #f) ;; for attributes with ~optional holes. 23 e 24 (if (> depth 0) 25 (map (λ (eᵢ) (leaves->datum eᵢ (sub1 depth))) e) 26 (if (syntax? e) 27 (syntax->datum e) 28 e)))) 29 30 31 (define-syntax (to-datum stx) 32 (syntax-case stx () 33 [(_ id) 34 (syntax-pattern-variable? (syntax-local-value #'id (λ () #f))) 35 (begin 36 (let* ([mapping (syntax-local-value #'id)] 37 [valvar (syntax-mapping-valvar mapping)] 38 [depth (syntax-mapping-depth mapping)]) 39 (if (attribute-mapping? (syntax-local-value valvar (λ () #f))) 40 #`(leaves->datum (attribute id) #,depth) 41 #`(leaves->datum #,valvar #,depth))))])) 42 43 (begin-for-syntax 44 (define (auto-pvar-proc self stx) 45 (cond 46 [(identifier? stx) 47 (datum->syntax stx 48 `(,(quote-syntax to-datum) ,stx) 49 stx 50 stx)] 51 [(and (pair? (syntax-e stx)) 52 (identifier? (car (syntax-e stx)))) 53 (datum->syntax stx 54 `((,(quote-syntax to-datum) ,(car (syntax-e stx))) 55 . 56 ,(cdr (syntax-e stx))) 57 stx 58 stx)] 59 [else (raise-syntax-error 60 'auto-syntax-e 61 "Improper use of auto-syntax-e pattern variable" 62 stx)])) 63 (define-values (struct:auto-pvar 64 -make-auto-pvar 65 auto-pvar? 66 auto-pvar-ref 67 auto-pvar-set!) 68 (make-struct-type 'auto-pvar 69 (eval #'struct:syntax-mapping 70 (module->namespace 'racket/private/sc)) 71 0 72 0 73 #f 74 null 75 (current-inspector) 76 auto-pvar-proc)) 77 (define (make-auto-pvar depth valvar) 78 (make-set!-transformer (-make-auto-pvar depth valvar)))) 79 80 (define-for-syntax (syntax->tree/ids e) 81 (cond [(identifier? e) e] 82 [(syntax? e) (syntax->tree/ids (syntax-e e))] 83 [(pair? e) (cons (syntax->tree/ids (car e)) 84 (syntax->tree/ids (cdr e)))] 85 [(vector? e) (map syntax->tree/ids (vector->list e))] 86 [(box? e) (syntax->tree/ids (unbox e))] 87 [(prefab-struct-key e) (map syntax->tree/ids (struct->list e))] 88 [else e])) 89 90 (define-for-syntax (syntax->ids e) 91 (filter identifier? (flatten (syntax->tree/ids e)))) 92 93 (define-syntax auto-syntax 94 (syntax-parser 95 [(_ (id ...) body ...) 96 #:with (pvar-id ...) (filter (λ (id) 97 (syntax-pattern-variable? 98 (syntax-local-value id (λ () #f)))) 99 (syntax->list #'(id ...))) 100 (with-disappeared-uses 101 (let () 102 (record-disappeared-uses (syntax->list #'(pvar-id ...))) 103 #'(let-syntax ([pvar-id 104 (let ([mapping (syntax-local-value 105 (quote-syntax pvar-id))]) 106 (make-auto-pvar (syntax-mapping-depth mapping) 107 (syntax-mapping-valvar mapping)))] 108 ...) 109 body ...)))])) 110 111 (define-syntax auto-with-syntax 112 (syntax-parser 113 [(_ ([pat e] ...) body ...) 114 #:with (id ...) (syntax->ids #'(pat ...)) 115 #'(with-syntax ([pat e] ...) 116 (auto-syntax (id ...) 117 body ...))])) 118 119 120 (define-syntax auto-syntax-case 121 (syntax-parser 122 [(_ stx-expression literals [pat guard+body ...] ...) 123 #:with (id ...) (syntax->ids #'(pat ...)) 124 #'(syntax-case stx-expression literals 125 [pat (auto-syntax (id ...) 126 guard+body ...)] 127 ...)]))