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