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