template.rkt (31082B)
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 racket/private/stx 12 racket/performance-hint 13 racket/private/promise) 14 (provide template 15 template/loc 16 datum-template 17 quasitemplate 18 quasitemplate/loc 19 define-template-metafunction 20 syntax-local-template-metafunction-introduce 21 ?? 22 ?@ 23 (for-syntax template-metafunction?)) 24 25 ;; ============================================================ 26 ;; Syntax of templates 27 28 ;; A Template (T) is one of: 29 ;; - pattern-variable 30 ;; - constant (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 ;; * (unsyntax expr) 38 39 ;; A HeadTemplate (H) is one of: 40 ;; - T 41 ;; - (?? H) 42 ;; - (?? H H) 43 ;; - (?@ . T) 44 ;; * (unquote-splicing expr) 45 46 (define-syntaxes (?? ?@) 47 (let ([tx (lambda (stx) (raise-syntax-error #f "not allowed as an expression" stx))]) 48 (values tx tx))) 49 50 (define-syntax ?@! #f) ;; private, escape-ignoring version of ?@, used by unsyntax-splicing 51 52 ;; ============================================================ 53 54 ;; Compile-time 55 56 ;; Parse template syntax into a Guide (AST--the name is left over from 57 ;; when the "guide" was a data structure interpreted at run time). 58 59 ;; The AST representation is designed to coincide with the run-time 60 ;; support, so compilation is just (datum->syntax #'here guide). 61 62 ;; A Guide (G) is one of: 63 ;; - (list 't-resyntax G) ;; template is syntax; re-syntax result 64 ;; - (list 't-const) ;; constant 65 ;; - (list 't-var PVar Boolean) ;; pattern variable 66 ;; - (list 't-cons/p G G) ;; template is non-syntax pair => no restx, use {car,cdr} 67 ;; - (list 't-vector G) ;; template is non-syntax vector 68 ;; - (list 't-struct G) ;; template is non-syntax prefab struct 69 ;; - (list 't-box G) ;; template is non-syntax box 70 ;; - (list 't-dots HG (listof (listof PVar)) Nat G/#f #f Boolean) 71 ;; - (list 't-dots G (listof (listof PVar)) Nat G/#f #t Boolean) 72 ;; - (list 't-append/p HG G) ;; template is non-syntax pair => no restx, use {car,cdr} 73 ;; - (list 't-escaped G) 74 ;; - (list 't-orelse G G) 75 ;; - (list 't-metafun Id G) 76 ;; - (list 't-relocate G Id) ;; relocate syntax 77 ;; - (list 't-resyntax/loc G Id) ;; like t-resyntax, but use alt srcloc 78 ;; For 't-var and 't-dots, the final boolean indicates whether the template 79 ;; fragment is in the left-hand side of an orelse (??). 80 81 ;; A HeadGuide (HG) is one of: 82 ;; - (list 'h-t G) 83 ;; - (list 'h-orelse HG HG/#f) 84 ;; - (list 'h-splice G) 85 86 ;; A PVar is (pvar Id Id Boolean Nat/#f) 87 ;; 88 ;; The first identifier (var) is from the syntax-mapping or attribute-binding. 89 ;; The second (lvar) is a local variable name used to hold its value (or parts 90 ;; thereof) in ellipsis iteration. The boolean is #f if var is trusted to have a 91 ;; (Listof^depth Syntax) value, #t if it needs to be checked. 92 ;; 93 ;; The depth-delta associated with a depth>0 pattern variable is the difference 94 ;; between the pattern variable's depth and the depth at which it is used. (For 95 ;; depth 0 pvars, it's #f.) For example, in 96 ;; 97 ;; (with-syntax ([x #'0] 98 ;; [(y ...) #'(1 2)] 99 ;; [((z ...) ...) #'((a b) (c d))]) 100 ;; (template (((x y) ...) ...))) 101 ;; 102 ;; the depth-delta for x is #f, the depth-delta for y is 1, and the depth-delta for 103 ;; z is 0. Coincidentally, the depth-delta is the same as the depth of the ellipsis 104 ;; form at which the variable should be moved to the loop-env. That is, the 105 ;; template above should be interpreted as roughly similar to 106 ;; 107 ;; (let ([x (pvar-value-of x)] 108 ;; [y (pvar-value-of y)] 109 ;; [z (pvar-value-of z)]) 110 ;; (for ([Lz (in-list z)]) ;; depth 0 111 ;; (for ([Ly (in-list y)] ;; depth 1 112 ;; [Lz (in-list Lz)]) 113 ;; (___ x Ly Lz ___)))) 114 115 (begin-for-syntax 116 117 (define-logger template) 118 119 (struct pvar (var lvar check? dd) #:prefab) 120 (struct template-metafunction (var)) 121 122 (define (ht-guide? x) (match x [(list 'h-t _) #t] [_ #f])) 123 (define (ht-guide-t x) (match x [(list 'h-t g) g])) 124 125 (define const-guide '(t-const)) 126 (define (const-guide? x) (equal? x const-guide)) 127 128 ;; ---------------------------------------- 129 ;; Parsing templates 130 131 ;; parse-template : Syntax Boolean -> (values (listof PVar) Guide) 132 (define (parse-template t stx?) 133 ;; env : Hasheq[ (cons syntax-mapping Nat) => PVar ] 134 (define env (make-hasheq)) 135 136 ;; parse-t : Stx Nat Boolean Boolean -> (values (dsetof PVar) Guide) 137 (define (parse-t t depth esc? in-try?) 138 (cond [(stx-pair? t) 139 (if (identifier? (stx-car t)) 140 (parse-t-pair/command t depth esc? in-try?) 141 (parse-t-pair/dots t depth esc? in-try?))] 142 [else (parse-t-nonpair t depth esc? in-try?)])) 143 144 ;; parse-t-pair/command : Stx Nat Boolean Boolean -> ... 145 ;; t is a stxpair w/ id in car; check if it is a "command" (metafun, escape, etc) 146 (define (parse-t-pair/command t depth esc? in-try?) 147 (syntax-case t (??) 148 [(DOTS template) 149 (and (not esc?) (free-identifier=? #'DOTS (quote-syntax ...))) 150 (let-values ([(drivers guide) (parse-t #'template depth #t in-try?)]) 151 (values drivers `(t-escaped ,guide)))] 152 [(?? t1 t2) 153 (not esc?) 154 (let-values ([(drivers1 guide1) (parse-t #'t1 depth esc? #t)] 155 [(drivers2 guide2) (parse-t #'t2 depth esc? in-try?)]) 156 (values (dset-union drivers1 drivers2) `(t-orelse ,guide1 ,guide2)))] 157 [(mf-id . _) 158 (and (not esc?) (lookup-metafun #'mf-id)) 159 (let-values ([(mf) (lookup-metafun #'mf-id)] 160 [(drivers guide) (parse-t (stx-cdr t) depth esc? in-try?)]) 161 (unless stx? (wrong-syntax "metafunctions not supported" #'mf-id)) 162 (values drivers `(t-metafun ,(template-metafunction-var mf) ,guide)))] 163 [_ (parse-t-pair/dots t depth esc? in-try?)])) 164 165 ;; parse-t-pair/dots : Stx Nat Boolean Boolean -> ... 166 ;; t is a stx pair; check for dots 167 (define (parse-t-pair/dots t depth esc? in-try?) 168 (define head (stx-car t)) 169 (define-values (tail nesting) 170 (let loop ([tail (stx-cdr t)] [nesting 0]) 171 (if (and (not esc?) (stx-pair? tail) (stx-dots? (stx-car tail))) 172 (loop (stx-cdr tail) (add1 nesting)) 173 (values tail nesting)))) 174 (if (zero? nesting) 175 (parse-t-pair/normal t depth esc? in-try?) 176 (let-values ([(hdrivers hguide) (parse-h head (+ depth nesting) esc? in-try?)] 177 [(tdrivers tguide) 178 (if (null? tail) 179 (values (dset) #f) 180 (parse-t tail depth esc? in-try?))]) 181 (when (dset-empty? hdrivers) 182 (wrong-syntax head "no pattern variables before ellipsis in template")) 183 (when (dset-empty? (dset-filter hdrivers (pvar/dd<=? depth))) 184 (let ([bad-dots ;; select the nestingth (last) ellipsis as the bad one 185 (stx-car (stx-drop nesting t))]) 186 ;; FIXME: improve error message? 187 (wrong-syntax bad-dots "too many ellipses in template"))) 188 ;; hdrivers is (listof (dsetof pvar)); compute pvars new to each level 189 (define hdriverss ;; per level 190 (for/list ([i (in-range nesting)]) 191 (dset-filter hdrivers (pvar/dd<=? (+ depth i))))) 192 (define new-hdriverss ;; per level 193 (let loop ([raw hdriverss] [last (dset)]) 194 (cond [(null? raw) null] 195 [else 196 (define new-hdrivers (dset->list (dset-subtract (car raw) last))) 197 (cons new-hdrivers (loop (cdr raw) (car raw)))]))) 198 (values (dset-union hdrivers tdrivers) 199 (let ([cons? (ht-guide? hguide)] 200 [hguide (if (ht-guide? hguide) (ht-guide-t hguide) hguide)]) 201 (resyntax t `(t-dots ,hguide ,new-hdriverss ,nesting ,tguide ,cons? ,in-try?))))))) 202 203 ;; parse-t-pair/normal : Stx Nat Boolean Boolean -> ... 204 ;; t is a normal stx pair 205 (define (parse-t-pair/normal t depth esc? in-try?) 206 (define-values (hdrivers hguide) (parse-h (stx-car t) depth esc? in-try?)) 207 (define-values (tdrivers tguide) (parse-t (stx-cdr t) depth esc? in-try?)) 208 (values (dset-union hdrivers tdrivers) 209 (let ([kind (if (ht-guide? hguide) 't-cons/p 't-append/p)] 210 [hguide (if (ht-guide? hguide) (ht-guide-t hguide) hguide)]) 211 (resyntax t `(,kind ,hguide ,tguide))))) 212 213 ;; parse-t-nonpair : Stx Nat Boolean Boolean -> ... 214 ;; PRE: t is not a stxpair 215 (define (parse-t-nonpair t depth esc? in-try?) 216 (syntax-case t (?? ?@) 217 [id 218 (identifier? #'id) 219 (cond [(and (not esc?) 220 (or (free-identifier=? #'id (quote-syntax ...)) 221 (free-identifier=? #'id (quote-syntax ??)) 222 (free-identifier=? #'id (quote-syntax ?@)))) 223 (wrong-syntax #'id "illegal use")] 224 [(lookup-metafun #'id) 225 (wrong-syntax t "illegal use of syntax metafunction")] 226 [(lookup #'id depth) 227 => (lambda (pvar) (values (dset pvar) `(t-var ,pvar ,in-try?)))] 228 [else (values (dset) const-guide)])] 229 [vec 230 (vector? (syntax-e #'vec)) 231 (let-values ([(drivers guide) 232 (parse-t (vector->list (syntax-e #'vec)) depth esc? in-try?)]) 233 (values drivers (if (const-guide? guide) const-guide (resyntax t `(t-vector ,guide)))))] 234 [pstruct 235 (prefab-struct-key (syntax-e #'pstruct)) 236 (let-values ([(drivers guide) 237 (let ([elems (cdr (vector->list (struct->vector (syntax-e #'pstruct))))]) 238 (parse-t elems depth esc? in-try?))]) 239 (values drivers (if (const-guide? guide) const-guide (resyntax t `(t-struct ,guide)))))] 240 [#&template 241 (let-values ([(drivers guide) 242 (parse-t #'template depth esc? in-try?)]) 243 (values drivers (if (const-guide? guide) const-guide (resyntax t `(t-box ,guide)))))] 244 [const 245 (values (dset) const-guide)])) 246 247 ;; parse-h : Syntax Nat Boolean Boolean -> (values (dsetof PVar) HeadGuide) 248 (define (parse-h h depth esc? in-try?) 249 (syntax-case h (?? ?@ ?@!) 250 [(?? t) 251 (not esc?) 252 (let-values ([(drivers guide) (parse-h #'t depth esc? #t)]) 253 (values drivers `(h-orelse ,guide #f)))] 254 [(?? t1 t2) 255 (not esc?) 256 (let-values ([(drivers1 guide1) (parse-h #'t1 depth esc? #t)] 257 [(drivers2 guide2) (parse-h #'t2 depth esc? in-try?)]) 258 (values (dset-union drivers1 drivers2) 259 (if (and (ht-guide? guide1) (ht-guide? guide2)) 260 `(h-t (t-orelse ,(ht-guide-t guide1) ,(ht-guide-t guide2))) 261 `(h-orelse ,guide1 ,guide2))))] 262 [(?@ . _) 263 (not esc?) 264 (let-values ([(drivers guide) (parse-t (stx-cdr h) depth esc? in-try?)]) 265 (values drivers `(h-splice ,guide)))] 266 [(?@! . _) 267 (let-values ([(drivers guide) (parse-t (stx-cdr h) depth esc? in-try?)]) 268 (values drivers `(h-splice ,guide)))] 269 [t 270 (let-values ([(drivers guide) (parse-t #'t depth esc? in-try?)]) 271 (values drivers `(h-t ,guide)))])) 272 273 ;; lookup : Identifier Nat -> PVar/#f 274 (define (lookup id depth) 275 (define variable? (if stx? syntax-pattern-variable? s-exp-pattern-variable?)) 276 (let ([v (syntax-local-value/record id variable?)]) 277 (cond [(syntax-pattern-variable? v) 278 (hash-ref! env (cons v depth) 279 (lambda () 280 (define pvar-depth (syntax-mapping-depth v)) 281 (define attr 282 (let ([attr (syntax-local-value (syntax-mapping-valvar v) (lambda () #f))]) 283 (and (attribute-mapping? attr) attr))) 284 (define var (if attr (attribute-mapping-var attr) (syntax-mapping-valvar v))) 285 (define check? (and attr (not (attribute-mapping-syntax? attr)))) 286 (cond [(zero? pvar-depth) 287 (pvar var var check? #f)] 288 [(>= depth pvar-depth) 289 (define lvar (car (generate-temporaries #'(pv_)))) 290 (pvar var lvar check? (- depth pvar-depth))] 291 [else 292 (wrong-syntax id "missing ellipses with pattern variable in template")])))] 293 [(s-exp-pattern-variable? v) 294 (hash-ref! env (cons v depth) 295 (lambda () 296 (define pvar-depth (s-exp-mapping-depth v)) 297 (define var (s-exp-mapping-valvar v)) 298 (define check? #f) 299 (cond [(zero? pvar-depth) 300 (pvar var var #f #f)] 301 [(>= depth pvar-depth) 302 (define lvar (car (generate-temporaries #'(pv_)))) 303 (pvar var lvar #f (- depth pvar-depth))] 304 [else 305 (wrong-syntax id "missing ellipses with pattern variable in template")])))] 306 [else 307 ;; id is a literal; check that for all x s.t. id = x.y, x is not an attribute 308 (for ([pfx (in-list (dotted-prefixes id))]) 309 (let ([pfx-v (syntax-local-value pfx (lambda () #f))]) 310 (when (and (syntax-pattern-variable? pfx-v) 311 (let ([valvar (syntax-mapping-valvar pfx-v)]) 312 (attribute-mapping? (syntax-local-value valvar (lambda () #f))))) 313 (wrong-syntax id "undefined nested attribute of attribute `~a'" (syntax-e pfx))))) 314 #f]))) 315 316 ;; resyntax : Stx Guide -> Guide 317 (define (resyntax t g) (if (and stx? (syntax? t)) `(t-resyntax ,g) g)) 318 319 (let-values ([(drivers guide) (parse-t t 0 #f #f)]) 320 (values (dset->list drivers) guide))) 321 322 ;; lookup-metafun : Identifier -> Metafunction/#f 323 (define (lookup-metafun id) 324 (syntax-local-value/record id template-metafunction?)) 325 326 (define (dotted-prefixes id) 327 (let* ([id-string (symbol->string (syntax-e id))] 328 [dot-locations (map car (regexp-match-positions* #rx"\\.[^.]" id-string))]) 329 (for/list ([loc (in-list dot-locations)]) 330 (datum->syntax id (string->symbol (substring id-string 0 loc)))))) 331 332 (define (stx-dots? x) (and (identifier? x) (free-identifier=? x (quote-syntax ...)))) 333 334 (define (cons/p-guide g1 g2) 335 (if (and (const-guide? g1) (const-guide? g2)) const-guide `(t-cons/p ,g1 ,g2))) 336 337 (define ((pvar/dd<=? expected-dd) x) 338 (let ([dd (pvar-dd x)]) (and dd (<= dd expected-dd)))) 339 340 (define (stx-drop n x) (for/fold ([x x]) ([i (in-range n)]) (stx-cdr x))) 341 342 (define (restx ctx v) (if (syntax? ctx) (datum->syntax ctx v ctx ctx) v)) 343 344 ;; ---------------------------------------- 345 ;; Relocating (eg, template/loc) 346 347 ;; Only relocate if relocation would affect a syntax pair originating 348 ;; from template structure. For example: 349 ;; (template/loc loc-stx (1 2 3)) => okay 350 ;; (template/loc loc-stx pvar) => don't relocate 351 352 ;; relocate-guide : Guide Id -> Guide 353 (define (relocate-guide g0 loc-id) 354 (define (error/no-relocate) 355 (wrong-syntax #f "cannot apply syntax location to template")) 356 (define (loop g) 357 (match g 358 [(list 't-resyntax g1) 359 (list 't-resyntax/loc g1 loc-id)] 360 [(list 't-const) 361 `(t-relocate ,g ,loc-id)] 362 ;; ---- 363 [(list 't-escaped g1) 364 (list 't-escaped (loop g1))] 365 [(list 't-orelse g1 g2) 366 (list 't-orelse (loop g1) (loop g2))] 367 ;; ---- 368 ;; Variables shouldn't be relocated. 369 [(list 't-var pvar in-try?) g] 370 ;; ---- 371 ;; Otherwise, cannot relocate: t-metafun, anything else? 372 [_ (error/no-relocate)])) 373 (loop g0)) 374 375 ;; ---------------------------------------- 376 ;; Compilation 377 378 ;; compile-guide : Guide -> Syntax[Expr] 379 (define (compile-guide g) (datum->syntax #'here g)) 380 381 ;; ---------------------------------------- 382 383 ;; do-template : Syntax Syntax Id/#f Boolean -> Syntax 384 (define (do-template ctx tstx loc-id stx?) 385 (with-disappeared-uses 386 (parameterize ((current-syntax-context ctx)) 387 (define-values (pvars pre-guide) (parse-template tstx stx?)) 388 (define guide (if loc-id (relocate-guide pre-guide loc-id) pre-guide)) 389 (syntax-arm 390 (with-syntax ([t tstx] 391 [quote-template (if stx? #'quote-syntax #'quote)] 392 [((var . pvar-val-var) ...) 393 (for/list ([pvar (in-list pvars)] #:when (pvar-dd pvar)) 394 (cons (pvar-lvar pvar) (pvar-var pvar)))]) 395 #`(let ([var pvar-val-var] ...) 396 (let ([tstx0 (quote-template t)]) 397 (#,(compile-guide guide) tstx0)))))))) 398 ) 399 400 (define-syntax (template stx) 401 (syntax-case stx () 402 [(template t) 403 (do-template stx #'t #f #t)] 404 [(template t #:properties _) 405 (begin 406 (log-template-error "template #:properties argument no longer supported: ~e" stx) 407 (do-template stx #'t #f))])) 408 409 (define-syntax (template/loc stx) 410 (syntax-case stx () 411 [(template/loc loc-expr t) 412 (syntax-arm 413 (with-syntax ([main-expr (do-template stx #'t #'loc-var #t)]) 414 #'(let ([loc-var (handle-loc '?/loc loc-expr)]) 415 main-expr)))])) 416 417 418 (define-syntax (datum-template stx) 419 (syntax-case stx () 420 [(datum-template t) 421 (do-template stx #'t #f #f)])) 422 423 (define (handle-loc who x) 424 (if (syntax? x) x (raise-argument-error who "syntax?" x))) 425 426 ;; ============================================================ 427 428 (begin-for-syntax 429 ;; process-quasi : Syntax -> (list Syntax[with-syntax-bindings] Syntax[expr]) 430 (define (process-quasi t0) 431 (define bindings null) 432 (define (add! binding) (set! bindings (cons binding bindings))) 433 (define (process t depth) 434 (define (loop t) (process t depth)) 435 (define (loop- t) (process t (sub1 depth))) 436 (define (loop+ t) (process t (add1 depth))) 437 (syntax-case t (unsyntax unsyntax-splicing quasitemplate) 438 [(unsyntax expr) 439 (cond [(zero? depth) 440 (with-syntax ([(us) (generate-temporaries #'(us))] 441 [ctx (datum->syntax #'expr 'ctx #'expr)]) 442 (add! (list #'us #'(check-unsyntax expr (quote-syntax ctx)))) 443 #'us)] 444 [else 445 (restx t (cons (stx-car t) (loop- (stx-cdr t))))])] 446 [((unsyntax-splicing expr) . _) 447 (cond [(zero? depth) 448 (with-syntax ([(us) (generate-temporaries #'(us))] 449 [ctx (datum->syntax #'expr 'ctx #'expr)]) 450 (add! (list #'us #'(check-unsyntax-splicing expr (quote-syntax ctx)))) 451 (restx t (cons #'(?@! . us) (loop (stx-cdr t)))))] 452 [else 453 (let ([tcar (stx-car t)] 454 [tcdr (stx-cdr t)]) 455 (restx t (cons (restx tcar (cons (stx-car tcar) (loop- (stx-cdr tcar)))) 456 (loop tcdr))))])] 457 [(quasitemplate _) 458 (restx t (cons (stx-car t) (loop+ (stx-cdr t))))] 459 [unsyntax 460 (raise-syntax-error #f "misuse within quasitemplate" t0 t)] 461 [unsyntax-splicing 462 (raise-syntax-error #f "misuse within quasitemplate" t0 t)] 463 [_ 464 (let ([d (if (syntax? t) (syntax-e t) t)]) 465 (cond [(pair? d) (restx t (cons (loop (car d)) (loop (cdr d))))] 466 [(vector? d) (restx t (list->vector (loop (vector->list d))))] 467 [(box? d) (restx t (box (loop (unbox d))))] 468 [(prefab-struct-key d) 469 => (lambda (key) 470 (apply make-prefab-struct key (loop (cdr (vector->list (struct->vector d))))))] 471 [else t]))])) 472 (define t* (process t0 0)) 473 (list (reverse bindings) t*))) 474 475 (define-syntax (quasitemplate stx) 476 (syntax-case stx () 477 [(quasitemplate t) 478 (with-syntax ([(bindings t*) (process-quasi #'t)]) 479 #'(with-syntax bindings (template t*)))])) 480 481 (define-syntax (quasitemplate/loc stx) 482 (syntax-case stx () 483 [(quasitemplate/loc loc-expr t) 484 (with-syntax ([(bindings t*) (process-quasi #'t)]) 485 #'(with-syntax bindings 486 (template/loc (handle-loc 'quasitemplate/loc loc-expr) t*)))])) 487 488 (define (check-unsyntax v ctx) 489 (datum->syntax ctx v ctx)) 490 (define (check-unsyntax-splicing v ctx) 491 (unless (stx-list? v) (raise-argument-error 'unsyntax-splicing "syntax->list" v)) 492 (datum->syntax ctx v ctx)) 493 494 ;; ============================================================ 495 496 ;; TODO: once PR https://github.com/racket/racket/pull/1591 is merged, use 497 ;; the exported prop:template-metafunction, template-metafunction? and 498 ;; template-metafunction-accessor. 499 (define-syntax (define-template-metafunction stx) 500 (syntax-case stx () 501 [(dsm (id arg ...) . body) 502 #'(dsm id (lambda (arg ...) . body))] 503 [(dsm id expr) 504 (identifier? #'id) 505 (with-syntax ([(internal-id) (generate-temporaries #'(id))]) 506 #'(begin (define internal-id expr) 507 (define-syntax id 508 (template-metafunction (quote-syntax internal-id)))))])) 509 510 511 ;; ============================================================ 512 ;; Run-time support 513 514 ;; Template transcription involves traversing the template syntax object, 515 ;; substituting pattern variables etc. The interpretation of the template is 516 ;; known at compile time, but we still need the template syntax at run time, 517 ;; because it is the basis for generated syntax objects (via datum->syntax). 518 519 ;; A template fragment (as opposed to the whole template expression) is compiled 520 ;; to a function of type (Stx -> Stx). It receives the corresponding template 521 ;; stx fragment as its argument. Pattern variables are passed through the 522 ;; environment. We rely on Racket's inliner and optimizer to simplify the 523 ;; resulting code to nearly first-order so that a new tree of closures is not 524 ;; allocated for each template transcription. 525 526 ;; Note: as an optimization, we track syntax vs non-syntax pairs in the template 527 ;; so we can generate more specific code (hopefully smaller and faster). 528 529 (define-syntax (t-var stx) 530 (syntax-case stx () 531 [(t-var #s(pvar var lvar check? _) in-try?) 532 (cond [(syntax-e #'check?) 533 #`(lambda (stx) (check-stx stx lvar in-try?))] 534 [else 535 #`(lambda (stx) lvar)])])) 536 537 (define-syntax (t-dots stx) 538 (syntax-case stx () 539 ;; Case 1: (x ...) where x is trusted. 540 [(t-dots (t-var #s(pvar _ lvar #f _) _) _drivers 1 #f #t _) 541 (begin 542 (log-template-debug "dots case 1: (x ...) where x is trusted") 543 #'(lambda (stx) lvar))] 544 ;; General case 545 [(t-dots head ((#s(pvar _ lvar check? _) ...) ...) nesting tail cons? in-try?) 546 (let ([cons? (syntax-e #'cons?)] 547 [lvarss (map syntax->list (syntax->list #'((lvar ...) ...)))] 548 [check?ss (syntax->datum #'((check? ...) ...))]) 549 (log-template-debug "dots general case: nesting = ~s, cons? = ~s, #vars = ~s" 550 (syntax-e #'nesting) cons? (apply + (map length lvarss))) 551 ;; AccElem = Stx if cons? is true, (Listof Stx) otherwise 552 ;; gen-level : (Listof PVar) Syntax[(Listof AccElem) -> (Listof AccElem)] 553 ;; -> Syntax[(Listof AccElem) -> (Listof AccElem)] 554 (define (gen-level lvars check?s inner) 555 (with-syntax ([(lvar ...) lvars] 556 [(var-value ...) (map var-value-expr lvars check?s)]) 557 #`(lambda (acc) 558 (let loop ([acc acc] [lvar var-value] ...) 559 (check-same-length lvar ...) 560 (if (and (pair? lvar) ...) 561 (loop (let ([lvar (car lvar)] ...) 562 (#,inner acc)) ;; inner has free refs to {var ...} 563 (cdr lvar) ...) 564 acc))))) 565 ;; var-value-expr : Id Boolean -> Syntax[List] 566 (define (var-value-expr lvar check?) 567 (if check? #`(check-list/depth stx #,lvar 1 in-try?) lvar)) 568 (define head-loop-code 569 (let nestloop ([lvarss lvarss] [check?ss check?ss] [old-lvars null] [old-check?s null]) 570 (cond [(null? lvarss) 571 #'(lambda (acc) (cons (head stx) acc))] 572 [else 573 (define lvars* (append (car lvarss) old-lvars)) 574 (define check?s* (append (car check?ss) old-check?s)) 575 (gen-level lvars* check?s* 576 (nestloop (cdr lvarss) (cdr check?ss) lvars* check?s*))]))) 577 (if cons? 578 #`(t-dots1* (lambda (stx) (#,head-loop-code null)) nesting (or tail (t-const))) 579 #`(t-dots* (lambda (stx) (#,head-loop-code null)) nesting (or tail (t-const)))))])) 580 581 (begin-encourage-inline 582 583 (define (stx-cadr x) (stx-car (stx-cdr x))) 584 (define (stx-cddr x) (stx-cdr (stx-cdr x))) 585 (define (stx-caddr x) (stx-car (stx-cdr (stx-cdr x)))) 586 (define (stx-drop n x) (for/fold ([x x]) ([i (in-range n)]) (stx-cdr x))) 587 (define (restx basis val) 588 (if (syntax? basis) (datum->syntax basis val basis basis) val)) 589 590 (define ((t-resyntax g) stx) (datum->syntax stx (g (syntax-e stx)) stx stx)) 591 (define ((t-relocate g loc) stx) 592 (define new-stx (g stx)) 593 (datum->syntax new-stx (syntax-e new-stx) loc new-stx)) 594 (define ((t-resyntax/loc g loc) stx) 595 (datum->syntax stx (g (syntax-e stx)) loc stx)) 596 597 (define ((t-const) stx) stx) 598 (define ((t-append/p h t) stx) (append (h (car stx)) (t (cdr stx)))) 599 (define ((t-cons/p h t) stx) (cons (h (car stx)) (t (cdr stx)))) 600 (define ((t-dots* h n t) stx) (revappend* (h (car stx)) (t (stx-drop (add1 n) stx)))) 601 (define ((t-dots1* h n t) stx) (revappend (h (car stx)) (t (stx-drop (add1 n) stx)))) 602 (define ((t-escaped g) stx) (g (stx-cadr stx))) 603 (define ((t-orelse g1 g2) stx) 604 (with-handlers ([absent-pvar? (lambda (e) (if g2 (g2 (stx-caddr stx)) null))]) 605 (g1 (stx-cadr stx)))) 606 (define ((t-vector g) stx) (list->vector (g (vector->list stx)))) 607 (define ((t-box g) stx) (box (g (unbox stx)))) 608 (define ((t-struct g) stx) 609 (define key (prefab-struct-key stx)) 610 (define elems (cdr (vector->list (struct->vector stx)))) 611 (apply make-prefab-struct key (g elems))) 612 (define ((t-metafun mf g) stx) 613 (define stx* (if (syntax? stx) stx (datum->syntax #f stx))) 614 (define v (restx stx* (cons (stx-car stx) (g (stx-cdr stx))))) 615 (apply-metafun mf stx* v)) 616 (define ((h-t g) stx) (list (g stx))) 617 (define (h-orelse g1 g2) (t-orelse g1 g2)) 618 (define ((h-splice g) stx) 619 (let ([r (g (stx-cdr stx))]) 620 (or (stx->list r) (error/splice stx r)))) 621 #| end begin-encourage-inline |#) 622 623 (define (apply-metafun mf stx v) 624 (define mark (make-syntax-introducer)) 625 (define old-mark (current-template-metafunction-introducer)) 626 (parameterize ((current-template-metafunction-introducer mark) 627 (old-template-metafunction-introducer old-mark)) 628 (define r (call-with-continuation-barrier (lambda () (mf (mark (old-mark v)))))) 629 (unless (syntax? r) 630 (raise-syntax-error #f "result of template metafunction was not syntax" stx)) 631 (old-mark (mark r)))) 632 633 (define (error/splice stx r) 634 (raise-syntax-error 'template "splicing template did not produce a syntax list" stx)) 635 636 ;; revappend* : (Listof (Listof X)) (Listof X) -> (Listof X) 637 (define (revappend* xss ys) 638 (if (null? xss) ys (revappend* (cdr xss) (append (car xss) ys)))) 639 640 ;; revappend : (Listof X) (Listof X) -> (Listof X) 641 (define (revappend xs ys) 642 (if (null? xs) ys (revappend (cdr xs) (cons (car xs) ys)))) 643 644 (define current-template-metafunction-introducer 645 (make-parameter (lambda (stx) (if (syntax-transforming?) (syntax-local-introduce stx) stx)))) 646 647 (define old-template-metafunction-introducer 648 (make-parameter #f)) 649 650 (define (syntax-local-template-metafunction-introduce stx) 651 (let ([mark (current-template-metafunction-introducer)] 652 [old-mark (old-template-metafunction-introducer)]) 653 (unless old-mark 654 (error 'syntax-local-template-metafunction-introduce 655 "must be called within the dynamic extent of a template metafunction")) 656 (mark (old-mark stx)))) 657 658 ;; Used to indicate absent pvar in template; ?? catches 659 ;; Note: not an exn, don't need continuation marks 660 #;(require (only-in rackunit require/expose)) 661 #;(require/expose syntax/parse/experimental/private/substitute 662 (absent-pvar 663 absent-pvar? 664 absent-pvar-ctx 665 absent-pvar-v 666 absent-pvar-wanted-list?)) 667 ;; this struct is only used in this file, and is not exported, so I guess it's 668 ;; ok to not steal the struct from syntax/parse/experimental/private/substitute 669 ;; Furthermore, the require/expose above does not work reliably. 670 (struct absent-pvar (ctx)) 671 672 (define (check-stx ctx v in-try?) 673 (cond [(syntax? v) v] 674 [(promise? v) (check-stx ctx (force v) in-try?)] 675 [(and in-try? (eq? v #f)) (raise (absent-pvar ctx))] 676 [else (err/not-syntax ctx v)])) 677 678 (define (check-list/depth ctx v0 depth0 in-try?) 679 (let depthloop ([v v0] [depth depth0]) 680 (cond [(zero? depth) v] 681 [(and (= depth 1) (list? v)) v] 682 [else 683 (let loop ([v v]) 684 (cond [(null? v) 685 null] 686 [(pair? v) 687 (let ([new-car (depthloop (car v) (sub1 depth))] 688 [new-cdr (loop (cdr v))]) 689 ;; Don't copy unless necessary 690 (if (and (eq? new-car (car v)) (eq? new-cdr (cdr v))) 691 v 692 (cons new-car new-cdr)))] 693 [(promise? v) 694 (loop (force v))] 695 [(and in-try? (eq? v #f)) 696 (raise (absent-pvar ctx))] 697 [else (err/not-syntax ctx v0)]))]))) 698 699 ;; FIXME: use raise-syntax-error instead, pass stx args 700 (define check-same-length 701 (case-lambda 702 [(a) (void)] 703 [(a b) 704 (unless (= (length a) (length b)) 705 (error 'syntax "incompatible ellipsis match counts for template"))] 706 [(a . bs) 707 (define alen (length a)) 708 (for ([b (in-list bs)]) 709 (unless (= alen (length b)) 710 (error 'template "incompatible ellipsis match counts for template")))])) 711 712 ;; Note: slightly different from error msg in syntax/parse/private/residual: 713 ;; here says "contains" instead of "is bound to", because might be within list 714 (define (err/not-syntax ctx v) 715 (raise-syntax-error #f (format "attribute contains non-syntax value\n value: ~e" v) ctx))