deriv-tokens.rkt (8069B)
1 #lang racket/base 2 (require parser-tools/lex 3 "deriv.rkt") 4 (provide (all-defined-out)) 5 6 ;; NOTE: trace.rkt also depends on some token numbers 7 ;; eg for enter-macro, local-value, etc 8 9 (define-tokens basic-empty-tokens 10 (start ; . 11 next ; . 12 next-group ; . 13 phase-up ; . 14 ... ; . 15 EOF ; . 16 enter-bind ; . 17 exit-bind ; . 18 exit-local-bind ; . 19 IMPOSSIBLE ; useful for error-handling clauses that have no 20 ; NoError counterpart 21 top-non-begin ; . 22 prepare-env ; . 23 )) 24 25 (define-tokens basic-tokens 26 (visit ; syntax 27 resolve ; identifier 28 enter-macro ; syntax 29 macro-pre-transform ; syntax 30 macro-post-transform ; (cons syntax syntax) 31 exit-macro ; syntax 32 enter-prim ; syntax 33 exit-prim ; syntax 34 return ; syntax 35 enter-block ; syntaxes 36 block->list ; syntaxes 37 block->letrec ; syntax(es?) 38 splice ; syntaxes 39 enter-list ; syntaxes 40 exit-list ; syntaxes 41 enter-check ; syntax 42 exit-check ; syntax 43 module-body ; (list-of (cons syntax boolean)) 44 syntax-error ; exn 45 lift-loop ; syntax = new form (let or begin; let if for_stx) 46 lift/let-loop ; syntax = new let form 47 module-lift-loop ; syntaxes = def-lifts, in reverse order lifted (???) 48 module-lift-end-loop ; syntaxes = statement-lifts ++ provide-lifts, in order lifted 49 lift ; (cons (listof id) syntax) 50 lift-statement ; syntax 51 lift-require ; (cons syntax (cons syntax syntax)) 52 lift-provide ; syntax 53 54 enter-local ; syntax 55 local-pre ; syntax 56 local-post ; syntax 57 exit-local ; syntax 58 59 local-bind ; (listof identifier) 60 opaque ; opaque-syntax 61 62 variable ; (cons identifier identifier) 63 tag ; syntax 64 65 rename-one ; syntax 66 rename-list ; (list-of syntax) 67 68 top-begin ; identifier 69 70 local-remark ; (listof (U string syntax)) 71 local-artificial-step ; (list syntax syntax syntax syntax) 72 73 track-origin ; (cons stx stx) 74 local-value ; identifier 75 local-value-result ; boolean 76 local-value-binding ; result of identifier-binding; added by trace.rkt, not expander 77 local-mess ; (listof event) 78 )) 79 80 (define-tokens renames-tokens 81 (renames-lambda ; (cons syntax syntax) 82 renames-case-lambda ; (cons syntax syntax) 83 renames-let ; (cons (listof syntax) syntax) 84 renames-letrec-syntaxes ; (cons (listof syntax) (cons (listof syntax) syntax)) 85 renames-block ; (cons syntax syntax) ... different, contains both pre+post 86 )) 87 88 ;; Empty tokens 89 (define-tokens prim-tokens 90 (prim-module prim-#%module-begin 91 prim-define-syntaxes prim-define-values 92 prim-if prim-wcm prim-begin prim-begin0 prim-#%app prim-lambda 93 prim-case-lambda prim-let-values prim-let*-values prim-letrec-values 94 prim-letrec-syntaxes+values prim-#%datum prim-#%top prim-stop 95 prim-quote prim-quote-syntax prim-require prim-require-for-syntax 96 prim-require-for-template prim-provide 97 prim-set! 98 prim-expression 99 prim-varref 100 prim-#%stratified-body 101 prim-begin-for-syntax 102 prim-submodule prim-submodule* 103 )) 104 105 ;; ** Signals to tokens 106 107 (define signal-mapping 108 ;; (number/#f symbol [token-constructor]) 109 `(;; Emitted from Scheme 110 (#f EOF) 111 (#f error ,token-syntax-error) 112 (#f start ,token-start) 113 (#f top-begin ,token-top-begin) 114 (#f top-non-begin ,token-top-non-begin) 115 (#f local-remark ,token-local-remark) 116 (#f local-artificial-step ,token-local-artificial-step) 117 (#f local-value-binding ,token-local-value-binding) 118 (#f local-mess ,token-local-mess) 119 120 ;; Standard signals 121 (0 visit ,token-visit) 122 (1 resolve ,token-resolve) 123 (2 return ,token-return) 124 (3 next ,token-next) 125 (4 enter-list ,token-enter-list) 126 (5 exit-list ,token-exit-list) 127 (6 enter-prim ,token-enter-prim) 128 (7 exit-prim ,token-exit-prim) 129 (8 enter-macro ,token-enter-macro) 130 (9 exit-macro ,token-exit-macro) 131 (10 enter-block ,token-enter-block) 132 (11 splice ,token-splice) 133 (12 block->list ,token-block->list) 134 (13 next-group ,token-next-group) 135 (14 block->letrec ,token-block->letrec) 136 (16 renames-let ,token-renames-let) 137 (17 renames-lambda ,token-renames-lambda) 138 (18 renames-case-lambda ,token-renames-case-lambda) 139 (19 renames-letrec-syntaxes ,token-renames-letrec-syntaxes) 140 (20 phase-up) 141 (21 macro-pre-transform ,token-macro-pre-transform) 142 (22 macro-post-transform ,token-macro-post-transform) 143 (23 module-body ,token-module-body) 144 (24 renames-block ,token-renames-block) 145 146 (100 prim-stop) 147 (101 prim-module) 148 (102 prim-#%module-begin) 149 (103 prim-define-syntaxes) 150 (104 prim-define-values) 151 (105 prim-if) 152 (106 prim-wcm) 153 (107 prim-begin) 154 (108 prim-begin0) 155 (109 prim-#%app) 156 (110 prim-lambda) 157 (111 prim-case-lambda) 158 (112 prim-let-values) 159 (113 prim-letrec-values) 160 (114 prim-letrec-syntaxes+values) 161 (115 prim-#%datum) 162 (116 prim-#%top) 163 (117 prim-quote) 164 (118 prim-quote-syntax) 165 (119 prim-require) 166 (120 prim-require-for-syntax) 167 (121 prim-require-for-template) 168 (122 prim-provide) 169 (123 prim-set!) 170 (124 prim-let*-values) 171 (125 variable ,token-variable) 172 (126 enter-check ,token-enter-check) 173 (127 exit-check ,token-exit-check) 174 (128 lift-loop ,token-lift-loop) 175 (129 lift ,token-lift) 176 (130 enter-local ,token-enter-local) 177 (131 exit-local ,token-exit-local) 178 (132 local-pre ,token-local-pre) 179 (133 local-post ,token-local-post) 180 (134 lift-statement ,token-lift-statement) 181 (135 lift-end-loop ,token-module-lift-end-loop) 182 (136 lift/let-loop ,token-lift/let-loop) 183 (137 module-lift-loop ,token-module-lift-loop) 184 (138 prim-expression) 185 (141 start ,token-start) 186 (142 tag ,token-tag) 187 (143 local-bind ,token-local-bind) 188 (144 enter-bind ,token-enter-bind) 189 (145 exit-bind ,token-exit-bind) 190 (146 opaque ,token-opaque) 191 (147 rename-list ,token-rename-list) 192 (148 rename-one ,token-rename-one) 193 (149 prim-varref) 194 (150 lift-require ,token-lift-require) 195 (151 lift-provide ,token-lift-provide) 196 (152 track-origin ,token-track-origin) 197 (153 local-value ,token-local-value) 198 (154 local-value-result ,token-local-value-result) 199 (155 prim-#%stratified-body) 200 (156 prim-begin-for-syntax) 201 (157 prepare-env) 202 (158 prim-submodule) 203 (159 prim-submodule*) 204 (160 exit-local-bind) 205 )) 206 207 (define (signal->symbol sig) 208 (if (symbol? sig) 209 sig 210 (cadr (assv sig signal-mapping)))) 211 212 (define token-mapping (map cdr signal-mapping)) 213 214 (define (tokenize sig val pos) 215 (let ([p (assv sig token-mapping)]) 216 (cond [(not p) 217 (error 'tokenize "bad signal: ~s" sig)] 218 [(null? (cdr p)) 219 (make-position-token sig pos pos)] 220 [else 221 (make-position-token ((cadr p) val) pos pos)])))