runtime.rkt (8640B)
1 #lang racket/base 2 (require racket/stxparam 3 stxparse-info/parse/private/residual ;; keep abs. path 4 stxparse-info/current-pvars 5 (for-syntax racket/base 6 racket/list 7 syntax/kerncase 8 syntax/strip-context 9 racket/private/sc 10 auto-syntax-e/utils 11 racket/syntax 12 syntax/parse/private/rep-data)) 13 14 (provide with 15 fail-handler 16 cut-prompt 17 undo-stack 18 wrap-user-code 19 20 fail 21 try 22 23 let-attributes 24 let-attributes* 25 let/unpack 26 27 defattrs/unpack 28 29 check-literal 30 no-shadow 31 curried-stxclass-parser 32 app-argu) 33 34 #| 35 TODO: rename file 36 37 This file contains "runtime" (ie, phase 0) auxiliary *macros* used in 38 expansion of syntax-parse etc. This file must not contain any 39 reference that persists in a compiled program; those must go in 40 residual.rkt. 41 |# 42 43 ;; == with == 44 45 (define-syntax (with stx) 46 (syntax-case stx () 47 [(with ([stxparam expr] ...) . body) 48 (with-syntax ([(var ...) (generate-temporaries #'(stxparam ...))]) 49 (syntax/loc stx 50 (let ([var expr] ...) 51 (syntax-parameterize ((stxparam (make-rename-transformer (quote-syntax var))) 52 ...) 53 . body))))])) 54 55 ;; == Control information == 56 57 (define-syntax-parameter fail-handler 58 (lambda (stx) 59 (wrong-syntax stx "internal error: fail-handler used out of context"))) 60 (define-syntax-parameter cut-prompt 61 (lambda (stx) 62 (wrong-syntax stx "internal error: cut-prompt used out of context"))) 63 (define-syntax-parameter undo-stack 64 (lambda (stx) 65 (wrong-syntax stx "internal error: undo-stack used out of context"))) 66 67 (define-syntax-rule (wrap-user-code e) 68 (with ([fail-handler #f] 69 [cut-prompt #t] 70 [undo-stack null]) 71 e)) 72 73 (define-syntax-rule (fail fs) 74 (fail-handler undo-stack fs)) 75 76 (define-syntax (try stx) 77 (syntax-case stx () 78 [(try e0 e ...) 79 (with-syntax ([(re ...) (reverse (syntax->list #'(e ...)))]) 80 (with-syntax ([(fh ...) (generate-temporaries #'(re ...))]) 81 (with-syntax ([(next-fh ... last-fh) #'(fail-handler fh ...)]) 82 #'(let* ([fh (lambda (undos1 fs1) 83 (with ([fail-handler 84 (lambda (undos2 fs2) 85 (unwind-to undos2 undos1) 86 (next-fh undos1 (cons fs1 fs2)))] 87 [undo-stack undos1]) 88 re))] 89 ...) 90 (with ([fail-handler 91 (lambda (undos2 fs2) 92 (unwind-to undos2 undo-stack) 93 (last-fh undo-stack fs2))] 94 [undo-stack undo-stack]) 95 e0)))))])) 96 97 ;; == Attributes 98 99 (define-for-syntax (parse-attr x) 100 (syntax-case x () 101 [#s(attr name depth syntax?) #'(name depth syntax?)])) 102 103 (define-syntax (let-attributes stx) 104 (syntax-case stx () 105 [(let-attributes ([a value] ...) . body) 106 (with-syntax ([((name depth syntax?) ...) 107 (map parse-attr (syntax->list #'(a ...)))]) 108 (with-syntax ([(vtmp ...) (generate-temporaries #'(name ...))] 109 [(stmp ...) (generate-temporaries #'(name ...))]) 110 #'(letrec-syntaxes+values 111 ([(stmp) (make-attribute-mapping (quote-syntax vtmp) 112 'name 'depth 'syntax?)] ...) 113 ([(vtmp) value] ...) 114 (letrec-syntaxes+values 115 ([(name) (make-auto-pvar 'depth (quote-syntax stmp))] ...) 116 () 117 (with-pvars (name ...) 118 . body)))))])) 119 120 ;; (let-attributes* (([id num] ...) (expr ...)) expr) : expr 121 ;; Special case: empty attrs need not match number of value exprs. 122 (define-syntax let-attributes* 123 (syntax-rules () 124 [(la* (() _) . body) 125 (let () . body)] 126 [(la* ((a ...) (val ...)) . body) 127 (let-attributes ([a val] ...) . body)])) 128 129 ;; (let/unpack (([id num] ...) expr) expr) : expr 130 ;; Special case: empty attrs need not match packed length 131 (define-syntax (let/unpack stx) 132 (syntax-case stx () 133 [(let/unpack (() packed) body) 134 #'body] 135 [(let/unpack ((a ...) packed) body) 136 (with-syntax ([(tmp ...) (generate-temporaries #'(a ...))]) 137 #'(let-values ([(tmp ...) (apply values packed)]) 138 (let-attributes ([a tmp] ...) body)))])) 139 140 (define-syntax (defattrs/unpack stx) 141 (syntax-case stx () 142 [(defattrs (a ...) packed) 143 (with-syntax ([((name depth syntax?) ...) 144 (map parse-attr (syntax->list #'(a ...)))]) 145 (with-syntax ([(vtmp ...) (generate-temporaries #'(name ...))] 146 [(stmp ...) (generate-temporaries #'(name ...))]) 147 #'(begin (define-values (vtmp ...) (apply values packed)) 148 (define-syntax stmp 149 (make-attribute-mapping (quote-syntax vtmp) 150 'name 'depth 'syntax?)) 151 ... 152 (define-syntax name (make-auto-pvar 'depth (quote-syntax stmp))) 153 ... 154 (define-pvars name ...))))])) 155 156 (define-syntax-rule (phase-of-enclosing-module) 157 (variable-reference->module-base-phase 158 (#%variable-reference))) 159 160 ;; (check-literal id phase-level-expr ctx) -> void 161 (define-syntax (check-literal stx) 162 (syntax-case stx () 163 [(check-literal id used-phase-expr ctx) 164 (let* ([ok-phases/ct-rel 165 ;; id is bound at each of ok-phases/ct-rel 166 ;; (phase relative to the compilation of the module in which the 167 ;; 'syntax-parse' (or related) form occurs) 168 (filter (lambda (p) (identifier-binding #'id p)) '(0 1 -1 #f))]) 169 ;; so we can avoid run-time call to identifier-binding if 170 ;; (+ (phase-of-enclosing-module) ok-phase/ct-rel) = used-phase 171 (with-syntax ([ok-phases/ct-rel ok-phases/ct-rel]) 172 #`(check-literal* (quote-syntax id) 173 used-phase-expr 174 (phase-of-enclosing-module) 175 'ok-phases/ct-rel 176 ;; If context is not stripped, racket complains about 177 ;; being unable to restore bindings for compiled code; 178 ;; and all we want is the srcloc, etc. 179 (quote-syntax #,(strip-context #'ctx)))))])) 180 181 ;; ==== 182 183 (begin-for-syntax 184 (define (check-shadow def) 185 (syntax-case def () 186 [(_def (x ...) . _) 187 (parameterize ((current-syntax-context def)) 188 (for ([x (in-list (syntax->list #'(x ...)))]) 189 (let ([v (syntax-local-value x (lambda _ #f))]) 190 (when (syntax-pattern-variable? v) 191 (wrong-syntax 192 x 193 ;; FIXME: customize "~do pattern" vs "#:do block" as appropriate 194 "definition in ~~do pattern must not shadow attribute binding")))))]))) 195 196 (define-syntax (no-shadow stx) 197 (syntax-case stx () 198 [(no-shadow e) 199 (let ([ee (local-expand #'e (syntax-local-context) 200 (kernel-form-identifier-list))]) 201 (syntax-case ee (begin define-values define-syntaxes) 202 [(begin d ...) 203 #'(begin (no-shadow d) ...)] 204 [(define-values . _) 205 (begin (check-shadow ee) 206 ee)] 207 [(define-syntaxes . _) 208 (begin (check-shadow ee) 209 ee)] 210 [_ 211 ee]))])) 212 213 (define-syntax (curried-stxclass-parser stx) 214 (syntax-case stx () 215 [(_ class argu) 216 (with-syntax ([#s(arguments (parg ...) (kw ...) _) #'argu]) 217 (let ([sc (get-stxclass/check-arity #'class #'class 218 (length (syntax->list #'(parg ...))) 219 (syntax->datum #'(kw ...)))]) 220 (with-syntax ([parser (stxclass-parser sc)]) 221 #'(lambda (x cx pr es undos fh cp rl success) 222 (app-argu parser x cx pr es undos fh cp rl success argu)))))])) 223 224 (define-syntax (app-argu stx) 225 (syntax-case stx () 226 [(aa proc extra-parg ... #s(arguments (parg ...) (kw ...) (kwarg ...))) 227 #| 228 Use keyword-apply directly? 229 #'(keyword-apply proc '(kw ...) (list kwarg ...) parg ... null) 230 If so, create separate no-keyword clause. 231 |# 232 ;; For now, let #%app handle it. 233 (with-syntax ([((kw-part ...) ...) #'((kw kwarg) ...)]) 234 #'(proc kw-part ... ... extra-parg ... parg ...))]))