fully-expanded-grammar-extract-bindings.rkt (3671B)
1 #lang racket/base 2 3 ;; This file is based on the file fully-expanded-grammar.rkt in the same folder. 4 5 (require syntax/parse 6 phc-toolkit/untyped 7 "optcontract.rkt" 8 racket/list 9 (for-template '#%kernel)) 10 11 (provide extract-bindings) 12 13 (define acc (make-parameter #f)) 14 15 (define/contract (acc! v) 16 (-> identifier? void?) 17 (set-box! (acc) (cons v (unbox (acc))))) 18 19 (define-syntax-class acc-id 20 #:attributes () 21 (pattern {~and id:id 22 {~do (acc! #'id)}})) 23 24 (define/contract (extract-bindings e) 25 (-> syntax? (listof identifier?)) 26 (parameterize ([acc (box '())]) 27 (syntax-parse e 28 [:expr 'ok]) 29 (fold-syntax (λ (stx rec) 30 (let ([d (syntax-property stx 'disappeared-binding)]) 31 (for-each acc! (filter identifier? (flatten d)))) 32 (rec stx)) 33 e) 34 (unbox (acc)))) 35 36 (define-syntax-class top-level-form 37 #:literals (#%expression module #%plain-module-begin begin begin-for-syntax) 38 (pattern :general-top-level-form) 39 (pattern (#%expression :expr)) 40 (pattern (module :id _module-path 41 (#%plain-module-begin 42 :module-level-form …))) 43 (pattern (begin :top-level-form …)) 44 (pattern (begin-for-syntax :top-level-form …))) 45 46 (define-syntax-class module-level-form 47 #:literals (#%provide begin-for-syntax #%declare) 48 (pattern :general-top-level-form) 49 (pattern (#%provide _raw-provide-spec …)) 50 (pattern (begin-for-syntax :module-level-form …)) 51 (pattern :submodule-form) 52 (pattern (#%declare _declaration-keyword …))) 53 54 (define-syntax-class submodule-form 55 #:literals (module #%plain-module-begin module* ) 56 (pattern (module :id _module-path 57 (#%plain-module-begin 58 :module-level-form …))) 59 (pattern (module* :id _module-path 60 (#%plain-module-begin 61 :module-level-form …))) 62 (pattern (module* :id #f 63 (#%plain-module-begin 64 :module-level-form …)))) 65 66 (define-syntax-class general-top-level-form 67 #:literals (define-values define-syntaxes #%require) 68 (pattern :expr) 69 (pattern (define-values (:id …) :expr)) 70 (pattern (define-syntaxes (:id …) :expr)) 71 (pattern (#%require _raw-require-spec …))) 72 73 (define-syntax-class expr 74 #:literals (lambda case-lambda if begin begin0 75 let-values letrec-values letrec-syntaxes+values 76 set! quote quote-syntax 77 with-continuation-mark 78 #%app #%top #%expression #%variable-reference 79 define-values) 80 (pattern :id) 81 (pattern (lambda :formals :expr …+)) 82 (pattern (case-lambda (:formals :expr …+) …)) 83 (pattern (if :expr :expr :expr)) 84 (pattern (begin :expr …+)) 85 (pattern (begin0 :expr :expr …)) 86 (pattern (let-values ([(:acc-id …) :expr] …) 87 :expr …+)) 88 (pattern (letrec-values ([(:acc-id …) :expr] …) 89 :expr …+)) 90 (pattern (letrec-syntaxes+values ([(:acc-id …) :expr] …) 91 ([(:acc-id …) :expr] …) 92 :expr …+)) 93 (pattern (set! :id :expr)) 94 (pattern (quote _datum)) 95 (pattern (quote-syntax _datum)) 96 (pattern (quote-syntax _datum #:local)) 97 (pattern (with-continuation-mark :expr :expr :expr)) 98 (pattern (#%app :expr …+)) 99 (pattern (#%top . :id)) 100 (pattern (#%expression :expr)) 101 (pattern (#%variable-reference :id)) 102 (pattern (#%variable-reference (#%top . :id))) 103 (pattern (#%variable-reference)) 104 (pattern (define-values (lifted-id:acc-id …) _lifted-expr))) 105 106 (define-syntax-class formals 107 (pattern (:acc-id …)) 108 (pattern (:acc-id …+ . :acc-id)) 109 (pattern :acc-id))