stxcase.rkt (30149B)
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/member racket/private/sc '#%kernel 10 auto-syntax-e/utils)) 11 12 (-define (datum->syntax/shape orig datum) 13 (if (syntax? datum) 14 datum 15 ;; Keeps 'paren-shape and any other properties: 16 (datum->syntax orig datum orig orig))) 17 18 (-define (catch-ellipsis-error thunk sexp sloc) 19 ((let/ec esc 20 (with-continuation-mark 21 exception-handler-key 22 (lambda (exn) 23 (esc 24 (lambda () 25 (if (exn:break? exn) 26 (raise exn) 27 (raise-syntax-error 28 'syntax 29 "incompatible ellipsis match counts for template" 30 sexp 31 sloc))))) 32 (let ([v (thunk)]) 33 (lambda () v)))))) 34 35 (-define substitute-stop 'dummy) 36 37 ;; pattern-substitute optimizes a pattern substitution by 38 ;; merging variables that look up the same simple mapping 39 (-define-syntax pattern-substitute 40 (lambda (stx) 41 (let ([pat (stx-car (stx-cdr stx))] 42 [subs (stx->list (stx-cdr (stx-cdr stx)))]) 43 (let ([ht-common (make-hash)] 44 [ht-map (make-hasheq)]) 45 ;; Determine merges: 46 (let loop ([subs subs]) 47 (unless (null? subs) 48 (let ([id (syntax-e (car subs))] 49 [expr (cadr subs)]) 50 (when (or (identifier? expr) 51 (and (stx-pair? expr) 52 (memq (syntax-e (stx-car expr)) 53 '(car cadr caddr cadddr 54 cdr cddr cdddr cddddr 55 list-ref list-tail)) 56 (stx-pair? (stx-cdr expr)) 57 (identifier? (stx-car (stx-cdr expr))))) 58 (let ([s-expr (syntax->datum expr)]) 59 (let ([new-id (hash-ref ht-common s-expr #f)]) 60 (if new-id 61 (hash-set! ht-map id new-id) 62 (hash-set! ht-common s-expr id)))))) 63 (loop (cddr subs)))) 64 ;; Merge: 65 (let ([new-pattern (if (zero? (hash-count ht-map)) 66 pat 67 (let loop ([stx pat]) 68 (cond 69 [(pair? stx) 70 (let ([a (loop (car stx))] 71 [b (loop (cdr stx))]) 72 (if (and (eq? a (car stx)) 73 (eq? b (cdr stx))) 74 stx 75 (cons a b)))] 76 [(symbol? stx) 77 (let ([new-id (hash-ref ht-map stx #f)]) 78 (or new-id stx))] 79 [(syntax? stx) 80 (let ([new-e (loop (syntax-e stx))]) 81 (if (eq? (syntax-e stx) new-e) 82 stx 83 (datum->syntax stx new-e stx stx)))] 84 [(vector? stx) 85 (list->vector (map loop (vector->list stx)))] 86 [(box? stx) (box (loop (unbox stx)))] 87 [else stx])))]) 88 (datum->syntax (quote-syntax here) 89 `(apply-pattern-substitute 90 ,new-pattern 91 (quote ,(let loop ([subs subs]) 92 (cond 93 [(null? subs) null] 94 [(hash-ref ht-map (syntax-e (car subs)) #f) 95 ;; Drop mapped id 96 (loop (cddr subs))] 97 [else 98 (cons (car subs) (loop (cddr subs)))]))) 99 . ,(let loop ([subs subs]) 100 (cond 101 [(null? subs) null] 102 [(hash-ref ht-map (syntax-e (car subs)) #f) 103 ;; Drop mapped id 104 (loop (cddr subs))] 105 [else 106 (cons (cadr subs) (loop (cddr subs)))]))) 107 stx)))))) 108 109 (-define apply-pattern-substitute 110 (lambda (stx sub-ids . sub-vals) 111 (let loop ([stx stx]) 112 (cond 113 [(pair? stx) (let ([a (loop (car stx))] 114 [b (loop (cdr stx))]) 115 (if (and (eq? a (car stx)) 116 (eq? b (cdr stx))) 117 stx 118 (cons a b)))] 119 [(symbol? stx) 120 (let sloop ([sub-ids sub-ids][sub-vals sub-vals]) 121 (cond 122 [(null? sub-ids) stx] 123 [(eq? stx (car sub-ids)) (car sub-vals)] 124 [else (sloop (cdr sub-ids) (cdr sub-vals))]))] 125 [(syntax? stx) 126 (let ([new-e (loop (syntax-e stx))]) 127 (if (eq? (syntax-e stx) new-e) 128 stx 129 (datum->syntax/shape stx new-e)))] 130 [(vector? stx) 131 (list->vector (map loop (vector->list stx)))] 132 [(box? stx) (box (loop (unbox stx)))] 133 [else stx])))) 134 135 (-define interp-match 136 (lambda (pat e literals immediate=?) 137 (interp-gen-match pat e literals immediate=? #f))) 138 139 (-define interp-s-match 140 (lambda (pat e literals immediate=?) 141 (interp-gen-match pat e literals immediate=? #t))) 142 143 (-define interp-gen-match 144 (lambda (pat e literals immediate=? s-exp?) 145 (let loop ([pat pat][e e][cap e]) 146 (cond 147 [(null? pat) 148 (if s-exp? 149 (null? e) 150 (stx-null? e))] 151 [(number? pat) 152 (and (if s-exp? (symbol? e) (identifier? e)) 153 (immediate=? e (vector-ref (if s-exp? literals (syntax-e literals)) pat)))] 154 [(not pat) 155 #t] 156 [else 157 (let ([i (vector-ref pat 0)]) 158 (cond 159 [(eq? i 'bind) 160 (let ([e (if s-exp? 161 e 162 (if (vector-ref pat 2) 163 (datum->syntax cap e cap) 164 e))]) 165 (if (vector-ref pat 1) 166 e 167 (list e)))] 168 [(eq? i 'pair) 169 (let ([match-head (vector-ref pat 1)] 170 [match-tail (vector-ref pat 2)] 171 [mh-did-var? (vector-ref pat 3)] 172 [mt-did-var? (vector-ref pat 4)]) 173 (let ([cap (if (syntax? e) e cap)]) 174 (and (stx-pair? e) 175 (let ([h (loop match-head (stx-car e) cap)]) 176 (and h 177 (let ([t (loop match-tail (stx-cdr e) cap)]) 178 (and t 179 (if mh-did-var? 180 (if mt-did-var? 181 (append h t) 182 h) 183 t))))))))] 184 [(eq? i 'quote) 185 (if s-exp? 186 (and (equal? (vector-ref pat 1) e) 187 null) 188 (and (syntax? e) 189 (equal? (vector-ref pat 1) (syntax-e e)) 190 null))] 191 [(eq? i 'ellipses) 192 (let ([match-head (vector-ref pat 1)] 193 [nest-cnt (vector-ref pat 2)] 194 [last? (vector-ref pat 3)]) 195 (and (if s-exp? 196 (list? e) 197 (stx-list? e)) 198 (if (zero? nest-cnt) 199 (andmap (lambda (e) (loop match-head e cap)) 200 (if s-exp? e (stx->list e))) 201 (let/ec esc 202 (let ([l (map (lambda (e) 203 (let ([m (loop match-head e cap)]) 204 (if m 205 m 206 (esc #f)))) 207 (if s-exp? e (stx->list e)))]) 208 (if (null? l) 209 (let loop ([cnt nest-cnt]) 210 (cond 211 [(= 1 cnt) (if last? '() '(()))] 212 [else (cons '() (loop (sub1 cnt)))])) 213 ((if last? stx-rotate* stx-rotate) l)))))))] 214 [(eq? i 'mid-ellipses) 215 (let ([match-head (vector-ref pat 1)] 216 [match-tail (vector-ref pat 2)] 217 [tail-cnt (vector-ref pat 3)] 218 [prop? (vector-ref pat 4)] 219 [mh-did-var? (vector-ref pat 5)] 220 [mt-did-var? (vector-ref pat 6)]) 221 (let-values ([(pre-items post-items ok?) 222 (split-stx-list e tail-cnt prop?)] 223 [(cap) (if (syntax? e) e cap)]) 224 (and ok? 225 (let ([h (loop match-head pre-items cap)]) 226 (and h 227 (let ([t (loop match-tail post-items cap)]) 228 (and t 229 (if mt-did-var? 230 (if mh-did-var? 231 (append h t) 232 t) 233 h))))))))] 234 [(eq? i 'veclist) 235 (and (if s-exp? 236 (vector? e) 237 (stx-vector? e #f)) 238 (loop (vector-ref pat 1) (vector->list (if s-exp? e (syntax-e e))) cap))] 239 [(eq? i 'vector) 240 (and (if s-exp? 241 (and (vector? e) (= (vector-length e) (vector-ref pat 1))) 242 (stx-vector? e (vector-ref pat 1))) 243 (let vloop ([p (vector-ref pat 2)][pos 0]) 244 (cond 245 [(null? p) null] 246 [else 247 (let ([clause (car p)]) 248 (let ([match-elem (car clause)] 249 [elem-did-var? (cdr clause)]) 250 (let ([m (loop match-elem (if s-exp? (vector-ref e pos) (stx-vector-ref e pos)) cap)]) 251 (and m 252 (let ([body (vloop (cdr p) (add1 pos))]) 253 (and body 254 (if elem-did-var? 255 (if (null? body) 256 m 257 (append m body)) 258 body)))))))])))] 259 [(eq? i 'box) 260 (let ([match-content (vector-ref pat 1)]) 261 (and (if s-exp? 262 (box? e) 263 (stx-box? e)) 264 (loop match-content (unbox (if s-exp? e (syntax-e e))) cap)))] 265 [(eq? i 'prefab) 266 (and (if s-exp? 267 (equal? (vector-ref pat 1) (prefab-struct-key e)) 268 (stx-prefab? (vector-ref pat 1) e)) 269 (loop (vector-ref pat 2) (cdr (vector->list (struct->vector (if s-exp? e (syntax-e e))))) cap))] 270 [else (error "yikes!" pat)]))])))) 271 272 (-define-syntax syntax-case** 273 (lambda (x) 274 (-define l (and (stx-list? x) (cdr (stx->list x)))) 275 (unless (and (stx-list? x) 276 (> (length l) 3)) 277 (raise-syntax-error 278 #f 279 "bad form" 280 x)) 281 (let ([who (car l)] 282 [arg-is-stx? (cadr l)] 283 [expr (caddr l)] 284 [kws (cadddr l)] 285 [lit-comp (cadddr (cdr l))] 286 [s-exp? (syntax-e (cadddr (cddr l)))] 287 [clauses (cddddr (cddr l))]) 288 (unless (stx-list? kws) 289 (raise-syntax-error 290 (syntax-e who) 291 "expected a parenthesized sequence of literal identifiers" 292 kws)) 293 (for-each 294 (lambda (lit) 295 (unless (identifier? lit) 296 (raise-syntax-error 297 (syntax-e who) 298 "literal is not an identifier" 299 lit))) 300 (stx->list kws)) 301 (for-each 302 (lambda (clause) 303 (unless (and (stx-list? clause) 304 (<= 2 (length (stx->list clause)) 3)) 305 (raise-syntax-error 306 (syntax-e who) 307 "expected a clause containing a pattern, an optional guard expression, and an expression" 308 clause))) 309 clauses) 310 (let ([patterns (map stx-car clauses)] 311 [fenders (map (lambda (clause) 312 (and (stx-pair? (stx-cdr (stx-cdr clause))) 313 (stx-car (stx-cdr clause)))) 314 clauses)] 315 [answers (map (lambda (clause) 316 (let ([r (stx-cdr (stx-cdr clause))]) 317 (if (stx-pair? r) 318 (stx-car r) 319 (stx-car (stx-cdr clause))))) 320 clauses)]) 321 (let* ([arg (quote-syntax arg)] 322 [rslt (quote-syntax rslt)] 323 [pattern-varss (map 324 (lambda (pattern) 325 (get-match-vars who pattern pattern (stx->list kws))) 326 (stx->list patterns))] 327 [lit-comp-is-mod? (and (identifier? lit-comp) 328 (free-identifier=? 329 lit-comp 330 (quote-syntax free-identifier=?)))]) 331 (syntax-arm 332 (datum->syntax 333 (quote-syntax here) 334 (list (quote-syntax let) (list (list arg (if (or s-exp? (syntax-e arg-is-stx?)) 335 expr 336 (list (quote-syntax datum->syntax) 337 (list 338 (quote-syntax quote-syntax) 339 (datum->syntax 340 expr 341 'here)) 342 expr)))) 343 (let loop ([patterns patterns] 344 [fenders fenders] 345 [unflat-pattern-varss pattern-varss] 346 [answers answers]) 347 (cond 348 [(null? patterns) 349 (list 350 (quote-syntax raise-syntax-error) 351 #f 352 "bad syntax" 353 arg)] 354 [else 355 (let ([rest (loop (cdr patterns) (cdr fenders) 356 (cdr unflat-pattern-varss) (cdr answers))]) 357 (let ([pattern (car patterns)] 358 [fender (car fenders)] 359 [unflat-pattern-vars (car unflat-pattern-varss)] 360 [answer (car answers)]) 361 (-define pattern-vars 362 (map (lambda (var) 363 (let loop ([var var]) 364 (if (syntax? var) 365 var 366 (loop (car var))))) 367 unflat-pattern-vars)) 368 (-define temp-vars 369 (map 370 (lambda (p) (gen-temp-id 'sc)) 371 pattern-vars)) 372 (-define tail-pattern-var (sub1 (length pattern-vars))) 373 ;; Here's the result expression for one match: 374 (let* ([do-try-next (if (car fenders) 375 (list (quote-syntax try-next)) 376 rest)] 377 [mtch (make-match&env 378 who 379 pattern 380 pattern 381 (stx->list kws) 382 (not lit-comp-is-mod?) 383 s-exp?)] 384 [cant-fail? (if lit-comp-is-mod? 385 (equal? mtch '(lambda (e) e)) 386 (equal? mtch '(lambda (e free-identifier=?) e)))] 387 ;; Avoid generating gigantic matching expressions. 388 ;; If it's too big, interpret at run time, instead 389 [interp? (and (not cant-fail?) 390 (zero? 391 (let sz ([mtch mtch][fuel 100]) 392 (cond 393 [(zero? fuel) 0] 394 [(pair? mtch) (sz (cdr mtch) 395 (sz (car mtch) 396 fuel))] 397 [(syntax? mtch) (sz (syntax-e mtch) (sub1 fuel))] 398 [else (sub1 fuel)]))))] 399 [mtch (if interp? 400 (let ([interp-box (box null)]) 401 (let ([pat (make-interp-match pattern (syntax->list kws) interp-box s-exp?)]) 402 (list 'lambda 403 '(e) 404 (list (if s-exp? 'interp-s-match 'interp-match) 405 (list 'quote pat) 406 'e 407 (if (null? (unbox interp-box)) 408 #f 409 (list (if s-exp? 'quote 'quote-syntax) 410 (list->vector (reverse (unbox interp-box))))) 411 lit-comp)))) 412 mtch)] 413 [m 414 ;; Do match, bind result to rslt: 415 (list (quote-syntax let) 416 (list 417 (list rslt 418 (if cant-fail? 419 arg 420 (list* (datum->syntax 421 (quote-syntax here) 422 mtch 423 pattern) 424 arg 425 (if (or interp? lit-comp-is-mod?) 426 null 427 (list lit-comp)))))) 428 ;; If match succeeded... 429 (list 430 (quote-syntax if) 431 (if cant-fail? 432 #t 433 rslt) 434 ;; Extract each name binding into a temp variable: 435 (list 436 (quote-syntax let) 437 (map (lambda (pattern-var temp-var) 438 (list 439 temp-var 440 (let ([pos (stx-memq-pos pattern-var pattern-vars)]) 441 (let ([accessor (cond 442 [(= tail-pattern-var pos) 443 (cond 444 [(eq? pos 0) 'tail] 445 [(eq? pos 1) (quote-syntax unsafe-cdr)] 446 [else 'tail])] 447 [(eq? pos 0) (quote-syntax unsafe-car)] 448 [else #f])]) 449 (cond 450 [(eq? accessor 'tail) 451 (if (zero? pos) 452 rslt 453 (list 454 (quote-syntax unsafe-list-tail) 455 rslt 456 pos))] 457 [accessor (list 458 accessor 459 rslt)] 460 [else (list 461 (quote-syntax unsafe-list-ref) 462 rslt 463 pos)]))))) 464 pattern-vars temp-vars) 465 ;; Tell nested `syntax' forms about the 466 ;; pattern-bound variables: 467 (list 468 (quote-syntax letrec-syntaxes+values) 469 (map (lambda (pattern-var unflat-pattern-var temp-var) 470 (list (list pattern-var) 471 (list 472 (if s-exp? 473 (quote-syntax make-s-exp-mapping) 474 (quote-syntax make-auto-pvar)) 475 ;; Tell it the shape of the variable: 476 (let loop ([var unflat-pattern-var][d 0]) 477 (if (syntax? var) 478 d 479 (loop (car var) (add1 d)))) 480 ;; Tell it the variable name: 481 (list 482 (quote-syntax quote-syntax) 483 temp-var)))) 484 pattern-vars unflat-pattern-vars 485 temp-vars) 486 null 487 (if fender 488 (list (quote-syntax if) fender 489 (list (quote-syntax with-pvars) 490 pattern-vars 491 answer) 492 do-try-next) 493 (list (quote-syntax with-pvars) 494 pattern-vars 495 answer)))) 496 do-try-next))]) 497 (if fender 498 (list 499 (quote-syntax let) 500 ;; Bind try-next to try next case 501 (list (list (quote try-next) 502 (list (quote-syntax lambda) 503 (list) 504 rest))) 505 ;; Try one match 506 m) 507 ;; Match try already embed the rest case 508 m))))]))) 509 x))))))) 510 511 (begin-for-syntax 512 (define-values (gen-template) 513 (lambda (x s-exp?) 514 (-define here-stx (quote-syntax here)) 515 (unless (and (stx-pair? x) 516 (let ([rest (stx-cdr x)]) 517 (and (stx-pair? rest) 518 (stx-null? (stx-cdr rest))))) 519 (raise-syntax-error 520 #f 521 "bad form" 522 x)) 523 (syntax-arm 524 (datum->syntax 525 here-stx 526 (let ([pattern (stx-car (stx-cdr x))]) 527 (let-values ([(unique-vars all-varss) (make-pexpand pattern #f null #f s-exp?)]) 528 (let ([var-bindings 529 (map 530 (lambda (var) 531 (and (let ([v (syntax-local-value var (lambda () #f))]) 532 (and (if s-exp? 533 (s-exp-pattern-variable? v) 534 (syntax-pattern-variable? v)) 535 v)))) 536 unique-vars)]) 537 (if (and (or (null? var-bindings) 538 (not (ormap (lambda (x) x) var-bindings))) 539 (no-ellipses? pattern)) 540 ;; Constant template: 541 (list (if s-exp? 542 (quote-syntax quote) 543 (quote-syntax quote-syntax)) 544 pattern) 545 ;; Non-constant: 546 (let ([proto-r (let loop ([vars unique-vars][bindings var-bindings]) 547 (if (null? bindings) 548 null 549 (let ([rest (loop (cdr vars) 550 (cdr bindings))]) 551 (if (car bindings) 552 (cons (let loop ([v (car vars)] 553 [d (if s-exp? 554 (s-exp-mapping-depth (car bindings)) 555 (syntax-mapping-depth (car bindings)))]) 556 (if (zero? d) 557 v 558 (loop (list v) (sub1 d)))) 559 rest) 560 rest))))] 561 [non-pattern-vars (let loop ([vars unique-vars][bindings var-bindings]) 562 (if (null? bindings) 563 null 564 (let ([rest (loop (cdr vars) 565 (cdr bindings))]) 566 (if (car bindings) 567 rest 568 (cons (car vars) rest)))))]) 569 (let ([build-from-template 570 ;; Even if we don't use the builder, we need to check 571 ;; for a well-formed pattern: 572 (make-pexpand pattern proto-r non-pattern-vars pattern s-exp?)] 573 [r (let loop ([vars unique-vars][bindings var-bindings][all-varss all-varss]) 574 (cond 575 [(null? bindings) null] 576 [(car bindings) 577 (cons 578 (syntax-property 579 (let ([id (if s-exp? 580 (s-exp-mapping-valvar (car bindings)) 581 (syntax-mapping-valvar (car bindings)))]) 582 (datum->syntax 583 id 584 (syntax-e id) 585 x)) 586 'disappeared-use 587 (map syntax-local-introduce (car all-varss))) 588 (loop (cdr vars) (cdr bindings) (cdr all-varss)))] 589 [else (loop (cdr vars) (cdr bindings) (cdr all-varss))]))]) 590 (if (identifier? pattern) 591 ;; Simple syntax-id lookup: 592 (car r) 593 ;; General case: 594 (list (datum->syntax 595 here-stx 596 build-from-template 597 pattern) 598 (let ([len (length r)]) 599 (cond 600 [(zero? len) (quote-syntax ())] 601 [(= len 1) (car r)] 602 [else 603 (cons (quote-syntax list*) r)])))))))))) 604 x))))) 605 606 (-define-syntax syntax (lambda (stx) (gen-template stx #f))) 607 (-define-syntax datum (lambda (stx) (gen-template stx #t))) 608 609 (#%provide (all-from racket/private/ellipses) syntax-case** syntax datum 610 (for-syntax syntax-pattern-variable?)))