syntax-parse.rkt (4273B)
1 #lang racket/base 2 3 (require (for-syntax racket/base 4 racket/private/sc 5 racket/contract 6 racket/syntax) 7 syntax/parse 8 version-case) 9 10 (version-case 11 [(version< (version) "6.90.0.24") 12 (require (rename-in (prefix-in - syntax/parse/private/residual) 13 [-make-attribute-mapping 14 compat-make-attribute-mapping]))] 15 [else 16 (require (rename-in (prefix-in - racket/private/template) 17 [-attribute-mapping --make-attribute-mapping]) 18 ;; must be an absolute path 19 (only-in syntax/parse/private/residual 20 check-attr-value)) 21 (define-for-syntax (-attribute-mapping-syntax? x) 22 ;; attribute-mapping-check is actually false when attribute-mapping-syntax? 23 ;; would have been true (thanks rmculpepper !) 24 (not (-attribute-mapping-check x))) 25 (define-for-syntax (compat-make-attribute-mapping valvar name depth syntax?) 26 (--make-attribute-mapping 27 valvar name depth (if syntax? #f (quote-syntax check-attr-value))))]) 28 29 (provide attribute* 30 (for-syntax attribute-info) 31 define-raw-attribute 32 define-raw-syntax-mapping) 33 34 (define-syntax (attribute* stx) 35 (syntax-case stx () 36 [(_ a) 37 (with-disappeared-uses 38 (let () 39 (record-disappeared-uses (list #'a)) 40 (let ([slv (syntax-local-value #'a (λ () #f))]) 41 (if (syntax-pattern-variable? slv) 42 (let* ([valvar (syntax-mapping-valvar slv)] 43 [valvar-slv (syntax-local-value valvar (λ () #f))]) 44 (if (-attribute-mapping? valvar-slv) 45 (-attribute-mapping-var valvar-slv) 46 valvar)) 47 (raise-syntax-error 48 'attribute* 49 "not bound as an attribute or pattern variable" 50 stx 51 #'a)))))])) 52 53 ;; The "accept" parameter allows forwards compatibility: 54 ;; if a new sort of syntax pattern variable is added, either it degrades 55 ;; gracefully into one of the accepted kinds, or an error is raised. 56 ;; The client does not have to deal with unknown cases, unless accept is #t. 57 (begin-for-syntax 58 (define/contract (attribute-info a [accept #t] [error? #t]) 59 (->* {identifier?} 60 {(or/c #t (listof symbol?)) 61 boolean?} 62 (or/c #f 63 (list/c 'attr 64 identifier? exact-nonnegative-integer? symbol? boolean?) 65 (list/c 'pvar 66 identifier? exact-nonnegative-integer?))) 67 (define slv (syntax-local-value a (λ () #f))) 68 ;; (assert (syntax-pattern-variable? slv)) 69 (define attr (and slv 70 (syntax-local-value (syntax-mapping-valvar slv) 71 (λ () #f)))) 72 (cond 73 [(and attr 74 (-attribute-mapping? attr) 75 (or (eq? #t accept) (and (list? accept) (memq 'attr accept)))) 76 (list 'attr 77 (-attribute-mapping-var attr) 78 (-attribute-mapping-depth attr) 79 (-attribute-mapping-name attr) 80 (-attribute-mapping-syntax? attr))] 81 [(and (syntax-pattern-variable? slv) 82 (or (eq? #t accept) (and (list? accept) (memq 'pvar accept)))) 83 (list 'pvar 84 (syntax-mapping-valvar slv) 85 (syntax-mapping-depth slv))] 86 [else 87 (when error? 88 (raise-syntax-error 'attribute-info 89 "not defined as an attribute or pattern variable" 90 a)) 91 #f]))) 92 93 (define-syntax-rule (define-raw-attribute name valvar val depth syntax?) 94 (begin 95 (define valvar 96 val) 97 (define-syntax tmp-attr 98 (compat-make-attribute-mapping (quote-syntax valvar) 99 'name 100 'depth 101 'syntax?)) 102 (define-syntax name 103 (make-syntax-mapping 'depth 104 (quote-syntax tmp-attr))))) 105 106 (define-syntax-rule (define-raw-syntax-mapping name valvar val depth) 107 (begin 108 (define valvar 109 val) 110 (define-syntax name 111 (make-syntax-mapping 'depth (quote-syntax valvar)))))