runtime.rkt (8716B)
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) (attribute-mapping (quote-syntax vtmp) 'name 'depth 112 (if 'syntax? #f (quote-syntax check-attr-value)))] 113 ...) 114 ([(vtmp) value] ...) 115 (letrec-syntaxes+values 116 ([(name) (make-auto-pvar 'depth (quote-syntax stmp))] ...) 117 () 118 (with-pvars (name ...) 119 . body)))))])) 120 121 ;; (let-attributes* (([id num] ...) (expr ...)) expr) : expr 122 ;; Special case: empty attrs need not match number of value exprs. 123 (define-syntax let-attributes* 124 (syntax-rules () 125 [(la* (() _) . body) 126 (let () . body)] 127 [(la* ((a ...) (val ...)) . body) 128 (let-attributes ([a val] ...) . body)])) 129 130 ;; (let/unpack (([id num] ...) expr) expr) : expr 131 ;; Special case: empty attrs need not match packed length 132 (define-syntax (let/unpack stx) 133 (syntax-case stx () 134 [(let/unpack (() packed) body) 135 #'body] 136 [(let/unpack ((a ...) packed) body) 137 (with-syntax ([(tmp ...) (generate-temporaries #'(a ...))]) 138 #'(let-values ([(tmp ...) (apply values packed)]) 139 (let-attributes ([a tmp] ...) body)))])) 140 141 (define-syntax (defattrs/unpack stx) 142 (syntax-case stx () 143 [(defattrs (a ...) packed) 144 (with-syntax ([((name depth syntax?) ...) 145 (map parse-attr (syntax->list #'(a ...)))]) 146 (with-syntax ([(vtmp ...) (generate-temporaries #'(name ...))] 147 [(stmp ...) (generate-temporaries #'(name ...))]) 148 #'(begin (define-values (vtmp ...) (apply values packed)) 149 (define-syntax stmp 150 (attribute-mapping (quote-syntax vtmp) 'name 'depth 151 (if 'syntax? #f (quote-syntax check-attr-value)))) 152 ... 153 (define-syntax name (make-auto-pvar 'depth (quote-syntax stmp))) 154 ... 155 (define-pvars name ...))))])) 156 157 (define-syntax-rule (phase-of-enclosing-module) 158 (variable-reference->module-base-phase 159 (#%variable-reference))) 160 161 ;; (check-literal id phase-level-expr ctx) -> void 162 (define-syntax (check-literal stx) 163 (syntax-case stx () 164 [(check-literal id used-phase-expr ctx) 165 (let* ([ok-phases/ct-rel 166 ;; id is bound at each of ok-phases/ct-rel 167 ;; (phase relative to the compilation of the module in which the 168 ;; 'syntax-parse' (or related) form occurs) 169 (filter (lambda (p) (identifier-binding #'id p)) '(0 1 -1 #f))]) 170 ;; so we can avoid run-time call to identifier-binding if 171 ;; (+ (phase-of-enclosing-module) ok-phase/ct-rel) = used-phase 172 (with-syntax ([ok-phases/ct-rel ok-phases/ct-rel]) 173 #`(check-literal* (quote-syntax id) 174 used-phase-expr 175 (phase-of-enclosing-module) 176 'ok-phases/ct-rel 177 ;; If context is not stripped, racket complains about 178 ;; being unable to restore bindings for compiled code; 179 ;; and all we want is the srcloc, etc. 180 (quote-syntax #,(strip-context #'ctx)))))])) 181 182 ;; ==== 183 184 (begin-for-syntax 185 (define (check-shadow def) 186 (syntax-case def () 187 [(_def (x ...) . _) 188 (parameterize ((current-syntax-context def)) 189 (for ([x (in-list (syntax->list #'(x ...)))]) 190 (let ([v (syntax-local-value x (lambda _ #f))]) 191 (when (syntax-pattern-variable? v) 192 (wrong-syntax 193 x 194 ;; FIXME: customize "~do pattern" vs "#:do block" as appropriate 195 "definition in ~~do pattern must not shadow attribute binding")))))]))) 196 197 (define-syntax (no-shadow stx) 198 (syntax-case stx () 199 [(no-shadow e) 200 (let ([ee (local-expand #'e (syntax-local-context) 201 (kernel-form-identifier-list))]) 202 (syntax-case ee (begin define-values define-syntaxes) 203 [(begin d ...) 204 #'(begin (no-shadow d) ...)] 205 [(define-values . _) 206 (begin (check-shadow ee) 207 ee)] 208 [(define-syntaxes . _) 209 (begin (check-shadow ee) 210 ee)] 211 [_ 212 ee]))])) 213 214 (define-syntax (curried-stxclass-parser stx) 215 (syntax-case stx () 216 [(_ class argu) 217 (with-syntax ([#s(arguments (parg ...) (kw ...) _) #'argu]) 218 (let ([sc (get-stxclass/check-arity #'class #'class 219 (length (syntax->list #'(parg ...))) 220 (syntax->datum #'(kw ...)))]) 221 (with-syntax ([parser (stxclass-parser sc)]) 222 #'(lambda (x cx pr es undos fh cp rl success) 223 (app-argu parser x cx pr es undos fh cp rl success argu)))))])) 224 225 (define-syntax (app-argu stx) 226 (syntax-case stx () 227 [(aa proc extra-parg ... #s(arguments (parg ...) (kw ...) (kwarg ...))) 228 #| 229 Use keyword-apply directly? 230 #'(keyword-apply proc '(kw ...) (list kwarg ...) parg ... null) 231 If so, create separate no-keyword clause. 232 |# 233 ;; For now, let #%app handle it. 234 (with-syntax ([((kw-part ...) ...) #'((kw kwarg) ...)]) 235 #'(proc kw-part ... ... extra-parg ... parg ...))]))