stxcase.rkt (21223B)
1 ;;---------------------------------------------------------------------- 2 ;; syntax-case and syntax 3 4 (module stxcase '#%kernel 5 (#%require racket/private/stx racket/private/small-scheme '#%paramz '#%unsafe 6 racket/private/ellipses 7 stxparse-info/current-pvars 8 (for-syntax racket/private/stx racket/private/small-scheme 9 racket/private/gen-temp racket/private/member racket/private/sc '#%kernel 10 auto-syntax-e/utils)) 11 12 (-define interp-match 13 (lambda (pat e literals immediate=?) 14 (interp-gen-match pat e literals immediate=? #f))) 15 16 (-define interp-s-match 17 (lambda (pat e literals immediate=?) 18 (interp-gen-match pat e literals immediate=? #t))) 19 20 (-define interp-gen-match 21 (lambda (pat e literals immediate=? s-exp?) 22 (let loop ([pat pat][e e][cap e]) 23 (cond 24 [(null? pat) 25 (if s-exp? 26 (null? e) 27 (stx-null? e))] 28 [(number? pat) 29 (and (if s-exp? (symbol? e) (identifier? e)) 30 (immediate=? e (vector-ref (if s-exp? literals (syntax-e literals)) pat)))] 31 [(not pat) 32 #t] 33 [else 34 (let ([i (vector-ref pat 0)]) 35 (cond 36 [(eq? i 'bind) 37 (let ([e (if s-exp? 38 e 39 (if (vector-ref pat 2) 40 (datum->syntax cap e cap) 41 e))]) 42 (if (vector-ref pat 1) 43 e 44 (list e)))] 45 [(eq? i 'pair) 46 (let ([match-head (vector-ref pat 1)] 47 [match-tail (vector-ref pat 2)] 48 [mh-did-var? (vector-ref pat 3)] 49 [mt-did-var? (vector-ref pat 4)]) 50 (let ([cap (if (syntax? e) e cap)]) 51 (and (stx-pair? e) 52 (let ([h (loop match-head (stx-car e) cap)]) 53 (and h 54 (let ([t (loop match-tail (stx-cdr e) cap)]) 55 (and t 56 (if mh-did-var? 57 (if mt-did-var? 58 (append h t) 59 h) 60 t))))))))] 61 [(eq? i 'quote) 62 (if s-exp? 63 (and (equal? (vector-ref pat 1) e) 64 null) 65 (and (syntax? e) 66 (equal? (vector-ref pat 1) (syntax-e e)) 67 null))] 68 [(eq? i 'ellipses) 69 (let ([match-head (vector-ref pat 1)] 70 [nest-cnt (vector-ref pat 2)] 71 [last? (vector-ref pat 3)]) 72 (and (if s-exp? 73 (list? e) 74 (stx-list? e)) 75 (if (zero? nest-cnt) 76 (andmap (lambda (e) (loop match-head e cap)) 77 (if s-exp? e (stx->list e))) 78 (let/ec esc 79 (let ([l (map (lambda (e) 80 (let ([m (loop match-head e cap)]) 81 (if m 82 m 83 (esc #f)))) 84 (if s-exp? e (stx->list e)))]) 85 (if (null? l) 86 (let loop ([cnt nest-cnt]) 87 (cond 88 [(= 1 cnt) (if last? '() '(()))] 89 [else (cons '() (loop (sub1 cnt)))])) 90 ((if last? stx-rotate* stx-rotate) l)))))))] 91 [(eq? i 'mid-ellipses) 92 (let ([match-head (vector-ref pat 1)] 93 [match-tail (vector-ref pat 2)] 94 [tail-cnt (vector-ref pat 3)] 95 [prop? (vector-ref pat 4)] 96 [mh-did-var? (vector-ref pat 5)] 97 [mt-did-var? (vector-ref pat 6)]) 98 (let-values ([(pre-items post-items ok?) 99 (split-stx-list e tail-cnt prop?)] 100 [(cap) (if (syntax? e) e cap)]) 101 (and ok? 102 (let ([h (loop match-head pre-items cap)]) 103 (and h 104 (let ([t (loop match-tail post-items cap)]) 105 (and t 106 (if mt-did-var? 107 (if mh-did-var? 108 (append h t) 109 t) 110 h))))))))] 111 [(eq? i 'veclist) 112 (and (if s-exp? 113 (vector? e) 114 (stx-vector? e #f)) 115 (loop (vector-ref pat 1) (vector->list (if s-exp? e (syntax-e e))) cap))] 116 [(eq? i 'vector) 117 (and (if s-exp? 118 (and (vector? e) (= (vector-length e) (vector-ref pat 1))) 119 (stx-vector? e (vector-ref pat 1))) 120 (let vloop ([p (vector-ref pat 2)][pos 0]) 121 (cond 122 [(null? p) null] 123 [else 124 (let ([clause (car p)]) 125 (let ([match-elem (car clause)] 126 [elem-did-var? (cdr clause)]) 127 (let ([m (loop match-elem (if s-exp? (vector-ref e pos) (stx-vector-ref e pos)) cap)]) 128 (and m 129 (let ([body (vloop (cdr p) (add1 pos))]) 130 (and body 131 (if elem-did-var? 132 (if (null? body) 133 m 134 (append m body)) 135 body)))))))])))] 136 [(eq? i 'box) 137 (let ([match-content (vector-ref pat 1)]) 138 (and (if s-exp? 139 (box? e) 140 (stx-box? e)) 141 (loop match-content (unbox (if s-exp? e (syntax-e e))) cap)))] 142 [(eq? i 'prefab) 143 (and (if s-exp? 144 (equal? (vector-ref pat 1) (prefab-struct-key e)) 145 (stx-prefab? (vector-ref pat 1) e)) 146 (loop (vector-ref pat 2) (cdr (vector->list (struct->vector (if s-exp? e (syntax-e e))))) cap))] 147 [else (error "yikes!" pat)]))])))) 148 149 (-define-syntax syntax-case** 150 (lambda (x) 151 (-define l (and (stx-list? x) (cdr (stx->list x)))) 152 (unless (and (stx-list? x) 153 (> (length l) 3)) 154 (raise-syntax-error 155 #f 156 "bad form" 157 x)) 158 (let ([who (car l)] 159 [arg-is-stx? (cadr l)] 160 [expr (caddr l)] 161 [kws (cadddr l)] 162 [lit-comp (cadddr (cdr l))] 163 [s-exp? (syntax-e (cadddr (cddr l)))] 164 [clauses (cddddr (cddr l))]) 165 (unless (stx-list? kws) 166 (raise-syntax-error 167 (syntax-e who) 168 "expected a parenthesized sequence of literal identifiers" 169 kws)) 170 (for-each 171 (lambda (lit) 172 (unless (identifier? lit) 173 (raise-syntax-error 174 (syntax-e who) 175 "literal is not an identifier" 176 lit))) 177 (stx->list kws)) 178 (for-each 179 (lambda (clause) 180 (unless (and (stx-list? clause) 181 (<= 2 (length (stx->list clause)) 3)) 182 (raise-syntax-error 183 (syntax-e who) 184 "expected a clause containing a pattern, an optional guard expression, and an expression" 185 clause))) 186 clauses) 187 (let ([patterns (map stx-car clauses)] 188 [fenders (map (lambda (clause) 189 (and (stx-pair? (stx-cdr (stx-cdr clause))) 190 (stx-car (stx-cdr clause)))) 191 clauses)] 192 [answers (map (lambda (clause) 193 (let ([r (stx-cdr (stx-cdr clause))]) 194 (if (stx-pair? r) 195 (stx-car r) 196 (stx-car (stx-cdr clause))))) 197 clauses)]) 198 (let* ([arg (quote-syntax arg)] 199 [rslt (quote-syntax rslt)] 200 [pattern-varss (map 201 (lambda (pattern) 202 (get-match-vars who pattern pattern (stx->list kws))) 203 (stx->list patterns))] 204 [lit-comp-is-mod? (and (identifier? lit-comp) 205 (free-identifier=? 206 lit-comp 207 (quote-syntax free-identifier=?)))]) 208 (syntax-arm 209 (datum->syntax 210 (quote-syntax here) 211 (list (quote-syntax let) (list (list arg (if (or s-exp? (syntax-e arg-is-stx?)) 212 expr 213 (list (quote-syntax datum->syntax) 214 (list 215 (quote-syntax quote-syntax) 216 (datum->syntax 217 expr 218 'here)) 219 expr)))) 220 (let loop ([patterns patterns] 221 [fenders fenders] 222 [unflat-pattern-varss pattern-varss] 223 [answers answers]) 224 (cond 225 [(null? patterns) 226 (list 227 (quote-syntax raise-syntax-error) 228 #f 229 "bad syntax" 230 arg)] 231 [else 232 (let ([rest (loop (cdr patterns) (cdr fenders) 233 (cdr unflat-pattern-varss) (cdr answers))]) 234 (let ([pattern (car patterns)] 235 [fender (car fenders)] 236 [unflat-pattern-vars (car unflat-pattern-varss)] 237 [answer (car answers)]) 238 (-define pattern-vars 239 (map (lambda (var) 240 (let loop ([var var]) 241 (if (syntax? var) 242 var 243 (loop (car var))))) 244 unflat-pattern-vars)) 245 (-define temp-vars 246 (map 247 (lambda (p) (gen-temp-id 'sc)) 248 pattern-vars)) 249 (-define tail-pattern-var (sub1 (length pattern-vars))) 250 ;; Here's the result expression for one match: 251 (let* ([do-try-next (if (car fenders) 252 (list (quote-syntax try-next)) 253 rest)] 254 [mtch (make-match&env 255 who 256 pattern 257 pattern 258 (stx->list kws) 259 (not lit-comp-is-mod?) 260 s-exp?)] 261 [cant-fail? (if lit-comp-is-mod? 262 (equal? mtch '(lambda (e) e)) 263 (equal? mtch '(lambda (e free-identifier=?) e)))] 264 ;; Avoid generating gigantic matching expressions. 265 ;; If it's too big, interpret at run time, instead 266 [interp? (and (not cant-fail?) 267 (zero? 268 (let sz ([mtch mtch][fuel 100]) 269 (cond 270 [(zero? fuel) 0] 271 [(pair? mtch) (sz (cdr mtch) 272 (sz (car mtch) 273 fuel))] 274 [(syntax? mtch) (sz (syntax-e mtch) (sub1 fuel))] 275 [else (sub1 fuel)]))))] 276 [mtch (if interp? 277 (let ([interp-box (box null)]) 278 (let ([pat (make-interp-match pattern (syntax->list kws) interp-box s-exp?)]) 279 (list 'lambda 280 '(e) 281 (list (if s-exp? 'interp-s-match 'interp-match) 282 (list 'quote pat) 283 'e 284 (if (null? (unbox interp-box)) 285 #f 286 (list (if s-exp? 'quote 'quote-syntax) 287 (list->vector (reverse (unbox interp-box))))) 288 lit-comp)))) 289 mtch)] 290 [m 291 ;; Do match, bind result to rslt: 292 (list (quote-syntax let) 293 (list 294 (list rslt 295 (if cant-fail? 296 arg 297 (list* (datum->syntax 298 (quote-syntax here) 299 mtch 300 pattern) 301 arg 302 (if (or interp? lit-comp-is-mod?) 303 null 304 (list lit-comp)))))) 305 ;; If match succeeded... 306 (list 307 (quote-syntax if) 308 (if cant-fail? 309 #t 310 rslt) 311 ;; Extract each name binding into a temp variable: 312 (list 313 (quote-syntax let) 314 (map (lambda (pattern-var temp-var) 315 (list 316 temp-var 317 (let ([pos (stx-memq-pos pattern-var pattern-vars)]) 318 (let ([accessor (cond 319 [(= tail-pattern-var pos) 320 (cond 321 [(eq? pos 0) 'tail] 322 [(eq? pos 1) (quote-syntax unsafe-cdr)] 323 [else 'tail])] 324 [(eq? pos 0) (quote-syntax unsafe-car)] 325 [else #f])]) 326 (cond 327 [(eq? accessor 'tail) 328 (if (zero? pos) 329 rslt 330 (list 331 (quote-syntax unsafe-list-tail) 332 rslt 333 pos))] 334 [accessor (list 335 accessor 336 rslt)] 337 [else (list 338 (quote-syntax unsafe-list-ref) 339 rslt 340 pos)]))))) 341 pattern-vars temp-vars) 342 ;; Tell nested `syntax' forms about the 343 ;; pattern-bound variables: 344 (list 345 (quote-syntax letrec-syntaxes+values) 346 (map (lambda (pattern-var unflat-pattern-var temp-var) 347 (list (list pattern-var) 348 (list 349 (if s-exp? 350 (quote-syntax make-s-exp-mapping) 351 (quote-syntax make-auto-pvar)) 352 ;; Tell it the shape of the variable: 353 (let loop ([var unflat-pattern-var][d 0]) 354 (if (syntax? var) 355 d 356 (loop (car var) (add1 d)))) 357 ;; Tell it the variable name: 358 (list 359 (quote-syntax quote-syntax) 360 temp-var)))) 361 pattern-vars unflat-pattern-vars 362 temp-vars) 363 null 364 (if fender 365 (list (quote-syntax if) fender 366 (list (quote-syntax with-pvars) 367 pattern-vars 368 answer) 369 do-try-next) 370 (list (quote-syntax with-pvars) 371 pattern-vars 372 answer)))) 373 do-try-next))]) 374 (if fender 375 (list 376 (quote-syntax let) 377 ;; Bind try-next to try next case 378 (list (list (quote try-next) 379 (list (quote-syntax lambda) 380 (list) 381 rest))) 382 ;; Try one match 383 m) 384 ;; Match try already embed the rest case 385 m))))]))) 386 x))))))) 387 388 (#%require "template.rkt") 389 (#%provide (all-from racket/private/ellipses) syntax-case** syntax syntax/loc datum 390 (for-syntax syntax-pattern-variable?)))