template.rkt (27962B)
1 #lang racket/base 2 (require (for-syntax racket/base 3 "dset.rkt" 4 racket/syntax 5 syntax/parse/private/minimatch 6 racket/private/stx ;; syntax/stx 7 racket/private/sc 8 racket/struct 9 auto-syntax-e/utils) 10 stxparse-info/parse/private/residual 11 "private/substitute.rkt") 12 (provide template 13 template/loc 14 quasitemplate 15 quasitemplate/loc 16 define-template-metafunction 17 syntax-local-template-metafunction-introduce 18 ?? 19 ?@ 20 (for-syntax template-metafunction?)) 21 22 #| 23 To do: 24 - improve error messages 25 |# 26 27 #| 28 A Template (T) is one of: 29 - pvar 30 - const (including () and non-pvar identifiers) 31 - (metafunction . T) 32 - (H . T) 33 - (H ... . T), (H ... ... . T), etc 34 - (?? T T) 35 - #(T*) 36 - #s(prefab-struct-key T*) 37 * (unquote expr) 38 39 A HeadTemplate (H) is one of: 40 - T 41 - (?? H) 42 - (?? H H) 43 - (?@ . T) 44 * (unquote-splicing expr) 45 |# 46 47 (begin-for-syntax 48 (define (do-template ctx tstx quasi? loc-id) 49 (with-disappeared-uses 50 (parameterize ((current-syntax-context ctx) 51 (quasi (and quasi? (box null)))) 52 (let*-values ([(guide deps props-guide) (parse-template tstx loc-id)] 53 [(vars) 54 (for/list ([dep (in-vector deps)]) 55 (cond [(pvar? dep) (pvar-var dep)] 56 [(template-metafunction? dep) 57 (template-metafunction-var dep)] 58 [else 59 (error 'template 60 "internal error: bad environment entry: ~e" 61 dep)]))]) 62 (with-syntax ([t tstx]) 63 (syntax-arm 64 (cond [(equal? guide '1) 65 ;; was (template pvar), implies props-guide = '_ 66 (car vars)] 67 [(and (equal? guide '_) (equal? props-guide '_)) 68 #'(quote-syntax t)] 69 [else 70 (with-syntax ([guide guide] 71 [props-guide props-guide] 72 [vars-vector 73 (if (pair? vars) 74 #`(vector . #,vars) 75 #''#())] 76 [((un-var . un-form) ...) 77 (if quasi? (reverse (unbox (quasi))) null)]) 78 #'(let ([un-var (handle-unsyntax un-form)] ...) 79 (substitute (quote-syntax t) 80 'props-guide 81 'guide 82 vars-vector)))])))))))) 83 84 (define-syntax (template stx) 85 (syntax-case stx () 86 [(template t) 87 (do-template stx #'t #f #f)] 88 [(template t #:properties (prop ...)) 89 (andmap identifier? (syntax->list #'(prop ...))) 90 (parameterize ((props-to-serialize (syntax->datum #'(prop ...))) 91 (props-to-transfer (syntax->datum #'(prop ...)))) 92 (do-template stx #'t #f #f))])) 93 94 (define-syntax (quasitemplate stx) 95 (syntax-case stx () 96 [(quasitemplate t) 97 (do-template stx #'t #t #f)] 98 [(quasitemplate t #:properties (prop ...)) 99 (andmap identifier? (syntax->list #'(prop ...))) 100 (parameterize ((props-to-serialize (syntax->datum #'(prop ...))) 101 (props-to-transfer (syntax->datum #'(prop ...)))) 102 ;; Same as above 103 (do-template stx #'t #t #f))])) 104 105 (define-syntaxes (template/loc quasitemplate/loc) 106 ;; FIXME: better to replace unsyntax form, shrink template syntax constant 107 (let ([make-tx 108 (lambda (quasi?) 109 (lambda (stx) 110 (syntax-case stx () 111 [(?/loc loc-expr t) 112 (syntax-arm 113 (with-syntax ([main-expr (do-template stx #'t quasi? #'loc-stx)]) 114 #'(let ([loc-stx (handle-loc '?/loc loc-expr)]) 115 main-expr)))] 116 [(?/loc loc-expr t #:properties (prop ...)) 117 (andmap identifier? (syntax->list #'(prop ...))) 118 (parameterize ((props-to-serialize (syntax->datum #'(prop ...))) 119 (props-to-transfer (syntax->datum #'(prop ...)))) 120 ;; Same as above 121 (syntax-arm 122 (with-syntax ([main-expr (do-template stx #'t quasi? #'loc-stx)]) 123 #'(let ([loc-stx (handle-loc '?/loc loc-expr)]) 124 main-expr))))])))]) 125 (values (make-tx #f) (make-tx #t)))) 126 127 (define (handle-loc who x) 128 (if (syntax? x) 129 x 130 (raise-argument-error who "syntax?" x))) 131 132 ;; FIXME: what lexical context should result of expr get if not syntax? 133 (define-syntax handle-unsyntax 134 (syntax-rules (unsyntax unsyntax-splicing) 135 [(handle-syntax (unsyntax expr)) expr] 136 [(handle-syntax (unsyntax-splicing expr)) expr])) 137 138 ;; substitute-table : hash[stx => translated-template] 139 ;; Cache for closure-compiled templates. Key is just syntax of 140 ;; template, since eq? templates must have equal? guides. 141 (define substitute-table (make-weak-hasheq)) 142 143 ;; props-syntax-table : hash[stx => stx] 144 (define props-syntax-table (make-weak-hasheq)) 145 146 (define (substitute stx props-guide g main-env) 147 (let* ([stx (if (eq? props-guide '_) 148 stx 149 (or (hash-ref props-syntax-table stx #f) 150 (let* ([pf (translate stx props-guide 0)] 151 [pstx (pf '#() #f)]) 152 (hash-set! props-syntax-table stx pstx) 153 pstx)))] 154 [f (or (hash-ref substitute-table stx #f) 155 (let ([f (translate stx g (vector-length main-env))]) 156 (hash-set! substitute-table stx f) 157 f))]) 158 (f main-env #f))) 159 160 ;; ---- 161 162 (define-syntaxes (?? ?@) 163 (let ([tx (lambda (stx) (raise-syntax-error #f "not allowed as an expression" stx))]) 164 (values tx tx))) 165 166 ;; ============================================================ 167 168 #| 169 See private/substitute for definition of Guide (G) and HeadGuide (HG). 170 171 A env-entry is one of 172 - (pvar syntax-mapping attribute-mapping/#f depth-delta) 173 - template-metafunction 174 175 The depth-delta associated with a depth>0 pattern variable is the difference 176 between the pattern variable's depth and the depth at which it is used. (For 177 depth 0 pvars, it's #f.) For example, in 178 179 (with-syntax ([x #'0] 180 [(y ...) #'(1 2)] 181 [((z ...) ...) #'((a b) (c d))]) 182 (template (((x y) ...) ...))) 183 184 the depth-delta for x is #f, the depth-delta for y is 1, and the depth-delta for 185 z is 0. Coincidentally, the depth-delta is the same as the depth of the ellipsis 186 form at which the variable should be moved to the loop-env. That is, the 187 template above should be interpreted as roughly similar to 188 189 (let ([x (pvar-value-of x)] 190 [y (pvar-value-of y)] 191 [z (pvar-value-of z)]) 192 (for ([Lz (in-list z)]) ;; depth 0 193 (for ([Ly (in-list y)] ;; depth 1 194 [Lz (in-list Lz)]) 195 (___ x Ly Lz ___)))) 196 197 A Pre-Guide is like a Guide but with env-entry and (setof env-entry) 198 instead of integers and integer vectors. 199 |# 200 201 (begin-for-syntax 202 (struct pvar (sm attr dd) #:prefab)) 203 204 ;; ============================================================ 205 206 207 ;; TODO: once PR https://github.com/racket/racket/pull/1591 is merged, use 208 ;; the exported prop:template-metafunction, template-metafunction? and 209 ;; template-metafunction-accessor. 210 (define-syntax (define-template-metafunction stx) 211 (syntax-case stx () 212 [(dsm (id arg ...) . body) 213 #'(dsm id (lambda (arg ...) . body))] 214 [(dsm id expr) 215 (identifier? #'id) 216 (with-syntax ([(internal-id) (generate-temporaries #'(id))]) 217 #'(begin (define internal-id expr) 218 (define-syntax id 219 (template-metafunction (quote-syntax internal-id)))))])) 220 221 (begin-for-syntax 222 (struct template-metafunction (var))) 223 224 ;; ============================================================ 225 226 (begin-for-syntax 227 228 ;; props-to-serialize determines what properties are saved even when 229 ;; code is compiled. (Unwritable values are dropped.) 230 ;; props-to-transfer determines what properties are transferred from 231 ;; template to stx constructed. 232 ;; If a property is in props-to-transfer but not props-to-serialize, 233 ;; compiling the module may have caused the property to disappear. 234 ;; If a property is in props-to-serialize but not props-to-transfer, 235 ;; it will show up only in constant subtrees. 236 ;; The behavior of 'syntax' is serialize '(), transfer '(paren-shape). 237 238 ;; props-to-serialize : (parameterof (listof symbol)) 239 (define props-to-serialize (make-parameter '())) 240 241 ;; props-to-transfer : (parameterof (listof symbol)) 242 (define props-to-transfer (make-parameter '(paren-shape))) 243 244 ;; quasi : (parameterof (or/c #f (list^n (boxof QuasiPairs)))) 245 ;; each list wrapper represents nested quasi wrapping 246 ;; QuasiPairs = (listof (cons/c identifier syntax)) 247 (define quasi (make-parameter #f)) 248 249 ;; parse-template : stx id/#f -> (values guide (vectorof env-entry) guide) 250 (define (parse-template t loc-id) 251 (let*-values ([(drivers pre-guide props-guide) (parse-t t 0 #f)] 252 [(drivers pre-guide) 253 (if loc-id 254 (let* ([loc-sm (make-auto-pvar 0 loc-id)] 255 [loc-pvar (pvar loc-sm #f #f)]) 256 (values (dset-add drivers loc-pvar) 257 (relocate-guide pre-guide loc-pvar))) 258 (values drivers pre-guide))]) 259 (let* ([main-env (dset->env drivers (hash))] 260 [guide (guide-resolve-env pre-guide main-env)]) 261 (values guide 262 (index-hash->vector main-env) 263 props-guide)))) 264 265 ;; dset->env : (dsetof env-entry) -> hash[env-entry => nat] 266 (define (dset->env drivers init-env) 267 (for/fold ([env init-env]) 268 ([pvar (in-list (dset->list drivers))] 269 [n (in-naturals (+ 1 (hash-count init-env)))]) 270 (hash-set env pvar n))) 271 272 ;; guide-resolve-env : pre-guide hash[env-entry => nat] -> guide 273 (define (guide-resolve-env g0 main-env) 274 (define (loop g loop-env) 275 (define (get-index x) 276 (let ([loop-index (hash-ref loop-env x #f)]) 277 (if loop-index 278 (- loop-index) 279 (hash-ref main-env x)))) 280 (match g 281 ['_ '_] 282 [(cons g1 g2) 283 (cons (loop g1 loop-env) (loop g2 loop-env))] 284 [(? pvar? pvar) 285 (if (pvar-check? pvar) 286 (vector 'check (get-index pvar)) 287 (get-index pvar))] 288 [(vector 'dots head new-hdrivers/level nesting '#f tail) 289 (let-values ([(sub-loop-env r-uptos) 290 (for/fold ([env (hash)] [r-uptos null]) 291 ([new-hdrivers (in-list new-hdrivers/level)]) 292 (let ([new-env (dset->env new-hdrivers env)]) 293 (values new-env (cons (hash-count new-env) r-uptos))))]) 294 (let ([sub-loop-vector (index-hash->vector sub-loop-env get-index)]) 295 (vector 'dots 296 (loop head sub-loop-env) 297 sub-loop-vector 298 nesting 299 (reverse r-uptos) 300 (loop tail loop-env))))] 301 [(vector 'app head tail) 302 (vector 'app (loop head loop-env) (loop tail loop-env))] 303 [(vector 'escaped g1) 304 (vector 'escaped (loop g1 loop-env))] 305 [(vector 'orelse g1 g2) 306 (vector 'orelse (loop g1 loop-env) (loop g2 loop-env))] 307 [(vector 'orelse-h g1 g2) 308 (vector 'orelse-h (loop g1 loop-env) (loop g2 loop-env))] 309 [(vector 'metafun mf g1) 310 (vector 'metafun 311 (get-index mf) 312 (loop g1 loop-env))] 313 [(vector 'vector g1) 314 (vector 'vector (loop g1 loop-env))] 315 [(vector 'struct g1) 316 (vector 'struct (loop g1 loop-env))] 317 [(vector 'box g1) 318 (vector 'box (loop (unbox g) loop-env))] 319 [(vector 'copy-props g1 keys) 320 (vector 'copy-props (loop g1 loop-env) keys)] 321 [(vector 'set-props g1 props-alist) 322 (vector 'set-props (loop g1 loop-env) props-alist)] 323 [(vector 'app-opt g1) 324 (vector 'app-opt (loop g1 loop-env))] 325 [(vector 'splice g1) 326 (vector 'splice (loop g1 loop-env))] 327 [(vector 'unsyntax var) 328 (vector 'unsyntax (get-index var))] 329 [(vector 'unsyntax-splicing var) 330 (vector 'unsyntax-splicing (get-index var))] 331 [(vector 'relocate g1 var) 332 (vector 'relocate (loop g1 loop-env) (get-index var))] 333 [else (error 'template "internal error: bad pre-guide: ~e" g)])) 334 (loop g0 '#hash())) 335 336 ;; ---------------------------------------- 337 338 ;; relocate-gude : stx guide -> guide 339 (define (relocate-guide g0 loc-pvar) 340 (define (relocate g) 341 (vector 'relocate g loc-pvar)) 342 (define (error/no-relocate) 343 (wrong-syntax #f "cannot apply syntax location to template")) 344 (define (loop g) 345 (match g 346 ['_ 347 (relocate g)] 348 [(cons g1 g2) 349 (relocate g)] 350 [(? pvar? g) 351 g] 352 [(vector 'dots head new-hdrivers/level nesting '#f tail) 353 ;; Ideally, should error. For perfect backwards compatability, 354 ;; should relocate. But if there are zero iterations, that 355 ;; means we'd relocate tail (which might be bad). Making 356 ;; relocation depend on number of iterations would be 357 ;; complicated. So just ignore. 358 g] 359 [(vector 'escaped g1) 360 (vector 'escaped (loop g1))] 361 [(vector 'vector g1) 362 (relocate g)] 363 [(vector 'struct g1) 364 (relocate g)] 365 [(vector 'box g1) 366 (relocate g)] 367 [(vector 'copy-props g1 keys) 368 (vector 'copy-props (loop g1) keys)] 369 [(vector 'unsyntax var) 370 g] 371 ;; ---- 372 [(vector 'app ghead gtail) 373 (match ghead 374 [(vector 'unsyntax-splicing _) g] 375 [_ (error/no-relocate)])] 376 ;; ---- 377 [(vector 'orelse g1 g2) 378 (error/no-relocate)] 379 [(vector 'orelse-h g1 g2) 380 (error/no-relocate)] 381 [(vector 'metafun mf g1) 382 (error/no-relocate)] 383 [(vector 'app-opt g1) 384 (error/no-relocate)] 385 [(vector 'splice g1) 386 (error/no-relocate)] 387 [(vector 'unsyntax-splicing var) 388 g] 389 [else (error 'template "internal error: bad guide for relocation: ~e" g0)])) 390 (loop g0)) 391 392 ;; ---------------------------------------- 393 394 (define (wrap-props stx env-set pre-guide props-guide) 395 (let ([saved-prop-values 396 (if (syntax? stx) 397 (for/fold ([entries null]) ([prop (in-list (props-to-serialize))]) 398 (let ([v (syntax-property stx prop)]) 399 (if (and v (quotable? v)) 400 (cons (cons prop v) entries) 401 entries))) 402 null)] 403 [copy-props 404 (if (syntax? stx) 405 (for/list ([prop (in-list (props-to-transfer))] 406 #:when (syntax-property stx prop)) 407 prop) 408 null)]) 409 (values env-set 410 (cond [(eq? pre-guide '_) 411 ;; No need to copy props; already on constant 412 '_] 413 [(pair? copy-props) 414 (vector 'copy-props pre-guide copy-props)] 415 [else pre-guide]) 416 (if (pair? saved-prop-values) 417 (vector 'set-props props-guide saved-prop-values) 418 props-guide)))) 419 420 (define (quotable? v) 421 (or (null? v) 422 (string? v) 423 (bytes? v) 424 (number? v) 425 (boolean? v) 426 (char? v) 427 (keyword? v) 428 (regexp? v) 429 (byte-regexp? v) 430 (and (box? v) (quotable? (unbox v))) 431 (and (symbol? v) (symbol-interned? v)) 432 (and (pair? v) (quotable? (car v)) (quotable? (cdr v))) 433 (and (vector? v) (andmap quotable? (vector->list v))) 434 (and (hash? v) (andmap quotable? (hash->list v))) 435 (and (prefab-struct-key v) (andmap quotable? (struct->list v))))) 436 437 (define (cons-guide g1 g2) 438 (if (and (eq? g1 '_) (eq? g2 '_)) '_ (cons g1 g2))) 439 440 (define (list-guide . gs) 441 (foldr cons-guide '_ gs)) 442 443 ;; parse-t : stx nat boolean -> (values (dsetof env-entry) pre-guide props-guide) 444 (define (parse-t t depth esc?) 445 (syntax-case t (?? ?@ unsyntax quasitemplate) 446 [id 447 (identifier? #'id) 448 (cond [(or (and (not esc?) 449 (or (free-identifier=? #'id (quote-syntax ...)) 450 (free-identifier=? #'id (quote-syntax ??)) 451 (free-identifier=? #'id (quote-syntax ?@)))) 452 (and (quasi) 453 (or (free-identifier=? #'id (quote-syntax unsyntax)) 454 (free-identifier=? #'id (quote-syntax unsyntax-splicing))))) 455 (wrong-syntax #'id "illegal use")] 456 [else 457 (let ([pvar (lookup #'id depth)]) 458 (cond [(pvar? pvar) 459 (values (dset pvar) pvar '_)] 460 [(template-metafunction? pvar) 461 (wrong-syntax t "illegal use of syntax metafunction")] 462 [else 463 (wrap-props #'id (dset) '_ '_)]))])] 464 [(mf . template) 465 (and (not esc?) 466 (identifier? #'mf) 467 (template-metafunction? (lookup #'mf #f))) 468 (let-values ([(mf) (lookup #'mf #f)] 469 [(drivers guide props-guide) (parse-t #'template depth esc?)]) 470 (values (dset-add drivers mf) 471 (vector 'metafun mf guide) 472 (cons-guide '_ props-guide)))] 473 [(unsyntax t1) 474 (quasi) 475 (let ([qval (quasi)]) 476 (cond [(box? qval) 477 (with-syntax ([(tmp) (generate-temporaries #'(unsyntax-expr))]) 478 (set-box! qval (cons (cons #'tmp t) (unbox qval))) 479 (let* ([fake-sm (make-auto-pvar 0 #'tmp)] 480 [fake-pvar (pvar fake-sm #f #f)]) 481 (values (dset fake-pvar) (vector 'unsyntax fake-pvar) '_)))] 482 [else 483 (parameterize ((quasi (car qval))) 484 (let-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)]) 485 (wrap-props t 486 drivers 487 (list-guide '_ guide) 488 (list-guide '_ props-guide))))]))] 489 [(quasitemplate t1) 490 ;; quasitemplate escapes inner unsyntaxes 491 (quasi) 492 (parameterize ((quasi (list (quasi)))) 493 (let-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)]) 494 (wrap-props t 495 drivers 496 (list-guide '_ guide) 497 (list-guide '_ props-guide))))] 498 [(DOTS template) 499 (and (not esc?) 500 (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...))) 501 (let-values ([(drivers guide props-guide) (parse-t #'template depth #t)]) 502 (values drivers (vector 'escaped guide) 503 (list-guide '_ props-guide)))] 504 [(?? t1 t2) 505 (not esc?) 506 (let-values ([(drivers1 guide1 props-guide1) (parse-t #'t1 depth esc?)] 507 [(drivers2 guide2 props-guide2) (parse-t #'t2 depth esc?)]) 508 (values (dset-union drivers1 drivers2) 509 (vector 'orelse guide1 guide2) 510 (list-guide '_ props-guide1 props-guide2)))] 511 [(head DOTS . tail) 512 (and (not esc?) 513 (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...))) 514 (let-values ([(nesting tail) 515 (let loop ([nesting 1] [tail #'tail]) 516 (syntax-case tail () 517 [(DOTS . tail) 518 (and (identifier? #'DOTS) (free-identifier=? #'DOTS (quote-syntax ...))) 519 (loop (add1 nesting) #'tail)] 520 [else (values nesting tail)]))]) 521 (let-values ([(hdrivers _hsplice? hguide hprops-guide) 522 (parse-h #'head (+ depth nesting) esc?)] 523 [(tdrivers tguide tprops-guide) 524 (parse-t tail depth esc?)]) 525 (when (dset-empty? hdrivers) 526 (wrong-syntax #'head "no pattern variables before ellipsis in template")) 527 (when (dset-empty? (dset-filter hdrivers (pvar/dd<=? depth))) 528 ;; FIXME: improve error message? 529 (let ([bad-dots 530 ;; select the nestingth (last) ellipsis as the bad one 531 (stx-car (stx-drop nesting t))]) 532 (wrong-syntax bad-dots "too many ellipses in template"))) 533 (wrap-props t 534 (dset-union hdrivers tdrivers) 535 ;; pre-guide hdrivers is (listof (setof pvar)) 536 ;; set of pvars new to each level 537 (let* ([hdrivers/level 538 (for/list ([i (in-range nesting)]) 539 (dset-filter hdrivers (pvar/dd<=? (+ depth i))))] 540 [new-hdrivers/level 541 (let loop ([raw hdrivers/level] [last (dset)]) 542 (cond [(null? raw) null] 543 [else 544 (cons (dset-subtract (car raw) last) 545 (loop (cdr raw) (car raw)))]))]) 546 (vector 'dots hguide new-hdrivers/level nesting #f tguide)) 547 (cons-guide hprops-guide (cons-guide '_ tprops-guide)))))] 548 [(head . tail) 549 (let-values ([(hdrivers hsplice? hguide hprops-guide) 550 (parse-h #'head depth esc?)] 551 [(tdrivers tguide tprops-guide) 552 (parse-t #'tail depth esc?)]) 553 (wrap-props t 554 (dset-union hdrivers tdrivers) 555 (cond [(and (eq? hguide '_) (eq? tguide '_)) '_] 556 [hsplice? (vector 'app hguide tguide)] 557 [else (cons hguide tguide)]) 558 (cons-guide hprops-guide tprops-guide)))] 559 [vec 560 (vector? (syntax-e #'vec)) 561 (let-values ([(drivers guide props-guide) 562 (parse-t (vector->list (syntax-e #'vec)) depth esc?)]) 563 (wrap-props t drivers 564 (if (eq? guide '_) '_ (vector 'vector guide)) 565 (if (eq? props-guide '_) '_ (vector 'vector props-guide))))] 566 [pstruct 567 (prefab-struct-key (syntax-e #'pstruct)) 568 (let-values ([(drivers guide props-guide) 569 (parse-t (cdr (vector->list (struct->vector (syntax-e #'pstruct)))) depth esc?)]) 570 (wrap-props t drivers 571 (if (eq? guide '_) '_ (vector 'struct guide)) 572 (if (eq? props-guide '_) '_ (vector 'struct props-guide))))] 573 [#&template 574 (let-values ([(drivers guide props-guide) 575 (parse-t #'template depth esc?)]) 576 (wrap-props t drivers 577 (if (eq? guide '_) '_ (vector 'box guide)) 578 (if (eq? props-guide '_) '_ (vector 'box props-guide))))] 579 [const 580 (wrap-props t (dset) '_ '_)])) 581 582 ;; parse-h : stx nat boolean -> (values (dsetof env-entry) boolean pre-head-guide props-guide) 583 (define (parse-h h depth esc?) 584 (syntax-case h (?? ?@ unsyntax-splicing) 585 [(?? t) 586 (not esc?) 587 (let-values ([(drivers splice? guide props-guide) 588 (parse-h #'t depth esc?)]) 589 (values drivers #t 590 (vector 'app-opt guide) 591 (list-guide '_ props-guide)))] 592 [(?? t1 t2) 593 (not esc?) 594 (let-values ([(drivers1 splice?1 guide1 props-guide1) (parse-h #'t1 depth esc?)] 595 [(drivers2 splice?2 guide2 props-guide2) (parse-h #'t2 depth esc?)]) 596 (values (dset-union drivers1 drivers2) 597 (or splice?1 splice?2) 598 (vector (if (or splice?1 splice?2) 'orelse-h 'orelse) 599 guide1 guide2) 600 (list-guide '_ props-guide1 props-guide2)))] 601 [(?@ . t) 602 (not esc?) 603 (let-values ([(drivers guide props-guide) (parse-t #'t depth esc?)]) 604 (values drivers #t (vector 'splice guide) (cons-guide '_ props-guide)))] 605 [(unsyntax-splicing t1) 606 (quasi) 607 (let ([qval (quasi)]) 608 (cond [(box? qval) 609 (with-syntax ([(tmp) (generate-temporaries #'(unsyntax-splicing-expr))]) 610 (set-box! qval (cons (cons #'tmp h) (unbox qval))) 611 (let* ([fake-sm (make-auto-pvar 0 #'tmp)] 612 [fake-pvar (pvar fake-sm #f #f)]) 613 (values (dset fake-pvar) #t (vector 'unsyntax-splicing fake-pvar) '_)))] 614 [else 615 (parameterize ((quasi (car qval))) 616 (let*-values ([(drivers guide props-guide) (parse-t #'t1 depth esc?)] 617 [(drivers guide props-guide) 618 (wrap-props h 619 drivers 620 (list-guide '_ guide) 621 (list-guide '_ props-guide))]) 622 (values drivers #f guide props-guide)))]))] 623 [t 624 (let-values ([(drivers guide props-guide) (parse-t #'t depth esc?)]) 625 (values drivers #f guide props-guide))])) 626 627 (define (lookup id depth) 628 (let ([v (syntax-local-value/record id (lambda (v) (or (syntax-pattern-variable? v) 629 (template-metafunction? v))))]) 630 (cond [(syntax-pattern-variable? v) 631 (let* ([pvar-depth (syntax-mapping-depth v)] 632 [attr (syntax-local-value (syntax-mapping-valvar v) (lambda () #f))] 633 [attr (and (attribute-mapping? attr) attr)]) 634 (cond [(not depth) ;; not looking for pvars, only for metafuns 635 #f] 636 [(zero? pvar-depth) 637 (pvar v attr #f)] 638 [(>= depth pvar-depth) 639 (pvar v attr (- depth pvar-depth))] 640 [else 641 (wrong-syntax id "missing ellipses with pattern variable in template")]))] 642 [(template-metafunction? v) 643 v] 644 [else 645 ;; id is a literal; check that for all x s.t. id = x.y, x is not an attribute 646 (for ([pfx (in-list (dotted-prefixes id))]) 647 (let ([pfx-v (syntax-local-value pfx (lambda () #f))]) 648 (when (and (syntax-pattern-variable? pfx-v) 649 (let ([valvar (syntax-mapping-valvar pfx-v)]) 650 (attribute-mapping? (syntax-local-value valvar (lambda () #f))))) 651 (wrong-syntax id "undefined nested attribute of attribute `~a'" (syntax-e pfx))))) 652 #f]))) 653 654 (define (dotted-prefixes id) 655 (let* ([id-string (symbol->string (syntax-e id))] 656 [dot-locations (map car (regexp-match-positions* #rx"\\.[^.]" id-string))]) 657 (for/list ([loc (in-list dot-locations)]) 658 (datum->syntax id (string->symbol (substring id-string 0 loc)))))) 659 660 (define (index-hash->vector hash [f values]) 661 (let ([vec (make-vector (hash-count hash))]) 662 (for ([(value index) (in-hash hash)]) 663 (vector-set! vec (sub1 index) (f value))) 664 vec)) 665 666 (define ((pvar/dd<=? expected-dd) x) 667 (match x 668 [(pvar sm attr dd) (and dd (<= dd expected-dd))] 669 [_ #f])) 670 671 (define (pvar-var x) 672 (match x 673 [(pvar sm '#f dd) (syntax-mapping-valvar sm)] 674 [(pvar sm attr dd) (attribute-mapping-var attr)])) 675 676 (define (pvar-check? x) 677 (match x 678 [(pvar sm '#f dd) #f] 679 [(pvar sm attr dd) (not (attribute-mapping-syntax? attr))])) 680 681 (define (stx-drop n x) 682 (cond [(zero? n) x] 683 [else (stx-drop (sub1 n) (stx-cdr x))])) 684 )