1#lang racket/base 2(require "../common/set.rkt" 3 "../common/struct-star.rkt" 4 "../common/parameter-like.rkt" 5 "../syntax/syntax.rkt" 6 "../syntax/property.rkt" 7 "../syntax/scope.rkt" 8 "../syntax/taint.rkt" 9 "../syntax/match.rkt" 10 "../syntax/original.rkt" 11 "../namespace/namespace.rkt" 12 "../namespace/module.rkt" 13 "../namespace/inspector.rkt" 14 "../syntax/binding.rkt" 15 "env.rkt" 16 "../syntax/track.rkt" 17 "../syntax/error.rkt" 18 "syntax-id-error.rkt" 19 "syntax-implicit-error.rkt" 20 "free-id-set.rkt" 21 "dup-check.rkt" 22 "use-site.rkt" 23 "../compile/main.rkt" 24 "../eval/top.rkt" 25 "../eval/direct.rkt" 26 "../namespace/core.rkt" 27 "../boot/runtime-primitive.rkt" 28 "context.rkt" 29 "lift-context.rkt" 30 "already-expanded.rkt" 31 "liberal-def-ctx.rkt" 32 "rename-trans.rkt" 33 "allowed-context.rkt" 34 "lift-key.rkt" 35 "../syntax/debug.rkt" 36 "reference-record.rkt" 37 "log.rkt" 38 "../common/performance.rkt" 39 "rebuild.rkt" 40 "parsed.rkt" 41 "expanded+parsed.rkt" 42 "implicit-property.rkt" 43 "bindings-arity-error.rkt") 44 45(provide expand 46 lookup 47 apply-transformer 48 49 register-variable-referenced-if-local! 50 51 expand/capture-lifts 52 expand-transformer 53 expand+eval-for-syntaxes-binding 54 context->transformer-context 55 eval-for-syntaxes-binding 56 eval-for-bindings 57 raise-bindings-arity-error 58 apply-rename-transformer 59 60 keep-properties-only 61 keep-properties-only~ 62 keep-as-needed 63 rebuild 64 attach-disappeared-transformer-bindings 65 increment-binding-layer 66 accumulate-def-ctx-scopes 67 rename-transformer-target-in-context 68 maybe-install-free=id-in-context! 69 70 maybe-create-use-site-scope 71 maybe-add-post-expansion) 72 73;; ---------------------------------------- 74 75;; Main expander dispatch 76(define (expand s ctx 77 ;; Applying a rename transformer substitutes 78 ;; an id without changing `s` 79 #:alternate-id [alternate-id #f] 80 ;; For expanding an implicit implemented by a rename transformer: 81 #:fail-non-transformer [fail-non-transformer #f]) 82 (log-expand ctx 'visit s) 83 (define content (syntax-content s)) 84 (cond 85 [(symbol? content) 86 (expand-identifier s ctx alternate-id)] 87 [(and (pair? content) 88 (syntax-identifier? (car content))) 89 (expand-id-application-form s ctx alternate-id 90 #:fail-non-transformer fail-non-transformer)] 91 [(or (pair? content) 92 (null? content)) 93 ;; An "application" form that doesn't start with an identifier, so 94 ;; use implicit `#%app` 95 (expand-implicit '#%app s ctx #f)] 96 [(already-expanded? content) 97 (expand-already-expanded s ctx)] 98 [else 99 ;; Anything other than an identifier or parens triggers the 100 ;; implicit `#%datum` form 101 (expand-implicit '#%datum s ctx #f)])) 102 103;; An identifier by itself (i.e., not after an open parenthesis) 104(define (expand-identifier s ctx alternate-id) 105 (define id (or alternate-id s)) 106 (guard-stop 107 id ctx s 108 (define binding (resolve+shift id (expand-context-phase ctx) 109 #:ambiguous-value 'ambiguous 110 #:immediate? #t)) 111 (log-expand ctx 'resolve id) 112 (cond 113 [(eq? binding 'ambiguous) 114 (raise-ambiguous-error id ctx)] 115 [(not binding) 116 ;; The implicit `#%top` form handles unbound identifiers 117 (expand-implicit '#%top (substitute-alternate-id s alternate-id) ctx s)] 118 [else 119 ;; Variable or form as identifier macro 120 (define-values (t primitive? insp-of-t protected?) 121 (lookup binding ctx id 122 #:in (and alternate-id s) 123 #:out-of-context-as-variable? (expand-context-in-local-expand? ctx))) 124 (dispatch t insp-of-t s id ctx binding primitive? protected?)]))) 125 126;; An "application" form that starts with an identifier 127(define (expand-id-application-form s ctx alternate-id 128 #:fail-non-transformer fail-non-transformer) 129 (define id (or alternate-id (car (syntax-e s)))) 130 (guard-stop 131 id ctx s 132 (define binding (resolve+shift id (expand-context-phase ctx) 133 #:ambiguous-value 'ambiguous 134 #:immediate? #t)) 135 (log-expand ctx 'resolve id) 136 (cond 137 [(eq? binding 'ambiguous) 138 (when fail-non-transformer (fail-non-transformer)) 139 (raise-ambiguous-error id ctx)] 140 [(not binding) 141 (when fail-non-transformer (fail-non-transformer)) 142 ;; The `#%app` binding might do something with unbound ids 143 (expand-implicit '#%app (substitute-alternate-id s alternate-id) ctx id)] 144 [else 145 ;; Find out whether it's bound as a variable, syntax, or core form 146 (define-values (t primitive? insp-of-t protected?) 147 (lookup binding ctx id 148 #:in (and alternate-id (car (syntax-e s))) 149 #:out-of-context-as-variable? (expand-context-in-local-expand? ctx))) 150 (cond 151 [(variable? t) 152 (when fail-non-transformer (fail-non-transformer)) 153 ;; Not as syntax or core form, so use implicit `#%app` 154 (expand-implicit '#%app (substitute-alternate-id s alternate-id) ctx id)] 155 [else 156 ;; Syntax or core form as "application" 157 (dispatch t insp-of-t s id ctx binding primitive? protected? 158 #:fail-non-transformer fail-non-transformer)])]))) 159 160;; Handle an implicit: `#%app`, `#%top`, or `#%datum`; this is similar 161;; to handling an id-application form, but there are several little 162;; differences: the binding must be a core form or transformer, 163;; an implicit `#%top` is handled specially, and so on 164(define (expand-implicit sym s ctx trigger-id) 165 (cond 166 [(expand-context-only-immediate? ctx) 167 (log-expand ctx 'stop/return s) 168 s] 169 [else 170 (define id (datum->syntax s sym)) 171 (guard-stop 172 id ctx s 173 (define b (resolve+shift id (expand-context-phase ctx) 174 #:ambiguous-value 'ambiguous 175 #:immediate? #t)) 176 (log-expand ctx 'resolve id) 177 (cond 178 [(eq? b 'ambiguous) 179 (raise-ambiguous-error id ctx)] 180 [else 181 (define-values (t primitive? insp-of-t protected?) 182 (if b (lookup b ctx id) (values #f #f #f #f))) 183 (cond 184 [(transformer? t) 185 (define fail-non-transformer 186 ;; Make sure a rename transformer eventually leads to syntax 187 (and (rename-transformer? t) 188 (lambda () 189 (raise-syntax-implicit-error s sym trigger-id ctx)))) 190 (dispatch-transformer t insp-of-t (make-explicit ctx sym s) id ctx b 191 #:fail-non-transformer fail-non-transformer)] 192 [(core-form? t) 193 (cond 194 [(and (eq? sym '#%top) 195 (eq? (core-form-name t) '#%top) 196 (expand-context-in-local-expand? ctx)) 197 (dispatch-implicit-#%top-core-form t s ctx)] 198 [else 199 (dispatch-core-form t (make-explicit ctx sym s) ctx)])] 200 [else 201 (define tl-id 202 (and (eq? sym '#%top) 203 (root-expand-context-top-level-bind-scope ctx) 204 (add-scope s (root-expand-context-top-level-bind-scope ctx)))) 205 (define tl-b (and tl-id (resolve tl-id (expand-context-phase ctx)))) 206 (cond 207 [tl-b 208 ;; Special case: the identifier is not bound and its scopes don't 209 ;; have a binding for `#%top`, but it's bound temporaily for compilation; 210 ;; treat the identifier as a variable reference 211 (if (and (expand-context-to-parsed? ctx) 212 (free-id-set-empty? (expand-context-stops ctx))) 213 (parsed-id tl-id tl-b #f) 214 (begin 215 (log-expand* ctx ['variable tl-id] ['return tl-id]) 216 tl-id))] 217 [else 218 (raise-syntax-implicit-error s sym trigger-id ctx)])])]))])) 219 220;; An expression that is already fully expanded via `local-expand-expression` 221(define (expand-already-expanded s ctx) 222 (define ae (syntax-e s)) 223 (define exp-s (already-expanded-s ae)) 224 (when (or (syntax-any-macro-scopes? s) 225 (not (eq? (expand-context-binding-layer ctx) 226 (already-expanded-binding-layer ae))) 227 (and (parsed? exp-s) 228 (not (and (expand-context-to-parsed? ctx) 229 (free-id-set-empty? (expand-context-stops ctx)))))) 230 (raise-syntax-error #f 231 (string-append "expanded syntax not in its original lexical context;\n" 232 " extra bindings or scopes in the current context") 233 (and (not (parsed? exp-s)) exp-s))) 234 (cond 235 [(expand-context-only-immediate? ctx) 236 (log-expand ctx 'stop/return s) 237 s] 238 [(parsed? exp-s) exp-s] 239 [else 240 (define result-s (syntax-track-origin exp-s s)) 241 (log-expand ctx 'opaque-expr result-s) ;; FIXME: or exp-s? 242 (if (and (expand-context-to-parsed? ctx) 243 (free-id-set-empty? (expand-context-stops ctx))) 244 (expand result-s ctx) ; fully expanded to compiled 245 result-s)])) 246 247(define (make-explicit ctx sym s) 248 (define insp (current-module-code-inspector)) 249 (define sym-s (immediate-datum->syntax s sym s 250 (if (syntax-has-property? s original-property-sym) 251 original-implicit-made-explicit-properties 252 implicit-made-explicit-properties) 253 insp)) 254 (define new-s (immediate-datum->syntax s (cons sym-s s) s 255 (syntax-props s) 256 insp)) 257 (log-expand ctx 'tag2 new-s s) 258 new-s) 259 260;; ---------------------------------------- 261 262;; Expand `s` given that the value `t` of the relevant binding, 263;; where `t` is either a core form, a macro transformer, some 264;; other compile-time value (which is an error), or a token 265;; indicating that the binding is a run-time variable 266(define (dispatch t insp-of-t s id ctx binding primitive? protected? 267 #:fail-non-transformer [fail-non-transformer #f]) 268 (cond 269 [(core-form? t) 270 (dispatch-core-form t s ctx)] 271 [(transformer? t) 272 (dispatch-transformer t insp-of-t s id ctx binding 273 #:fail-non-transformer fail-non-transformer)] 274 [(variable? t) 275 (dispatch-variable t s id ctx binding primitive? protected?)] 276 [else 277 ;; Some other compile-time value: 278 (raise-syntax-error #f "illegal use of syntax" s 279 #f null 280 (format "\n value at phase ~s: ~e" 281 (add1 (expand-context-phase ctx)) 282 t))])) 283 284;; Call a core-form expander (e.g., `lambda`) 285(define (dispatch-core-form t s ctx) 286 (cond 287 [(expand-context-only-immediate? ctx) 288 (log-expand ctx 'stop/return s) 289 s] 290 [(expand-context-observer ctx) 291 (log-expand ctx 'enter-prim s) 292 (define result-s ((core-form-expander t) s ctx)) 293 (log-expand ctx 'exit-prim/return (extract-syntax result-s)) 294 result-s] 295 [else 296 ;; As previous case, but as a tail call: 297 ((core-form-expander t) s ctx)])) 298 299;; Special favor to `local-expand` from `expand-implicit`: call 300;; `#%top` form without making `#%top` explicit in the form 301(define (dispatch-implicit-#%top-core-form t s ctx) 302 (log-expand ctx 'enter-prim s) 303 (define result-s ((core-form-expander t) s ctx #t)) 304 (log-expand ctx 'exit-prim/return result-s) 305 result-s) 306 307;; Call a macro expander, taking into account whether it works 308;; in the current context, whether to expand just once, etc. 309(define (dispatch-transformer t insp-of-t s id ctx binding 310 #:fail-non-transformer fail-non-transformer) 311 (cond 312 [(not-in-this-expand-context? t ctx) 313 (define adj-s (avoid-current-expand-context (substitute-alternate-id s id) t ctx)) 314 (log-expand ctx 'tag/context adj-s) 315 (expand adj-s ctx)] 316 [(and (expand-context-parsing-expanded? ctx) 317 ;; It's ok to have a rename transformer whose target 318 ;; is a primitive form, so if it's a rename transformer, 319 ;; delay the check for another step 320 (not (rename-transformer? t))) 321 (raise-syntax-error #f 322 "encountered a macro binding in form that should be fully expanded" 323 s)] 324 [(rename-transformer? t) 325 (cond 326 [(expand-context-just-once? ctx) s] 327 [else 328 (define alt-id (apply-rename-transformer t id ctx)) 329 (log-expand ctx 'rename-transformer alt-id) 330 (expand s ctx 331 #:alternate-id alt-id 332 #:fail-non-transformer fail-non-transformer)])] 333 [else 334 ;; Apply transformer and expand again 335 (define-values (exp-s re-ctx) 336 (apply-transformer t insp-of-t s id ctx binding)) 337 (cond 338 [(expand-context-just-once? ctx) exp-s] 339 [else (expand exp-s re-ctx)])])) 340 341;; Handle the expansion of a variable to itself 342(define (dispatch-variable t s id ctx binding primitive? protected?) 343 (cond 344 [(expand-context-only-immediate? ctx) 345 (log-expand ctx 'stop/return id) 346 id] 347 [else 348 (log-expand ctx 'variable s id) 349 ;; A reference to a variable expands to itself 350 (register-variable-referenced-if-local! binding ctx) 351 ;; If the variable is locally bound, replace the use's scopes with the binding's scopes 352 (define result-s (substitute-variable id t #:no-stops? (free-id-set-empty-or-just-module*? (expand-context-stops ctx)))) 353 (cond 354 [(and (expand-context-to-parsed? ctx) 355 (free-id-set-empty? (expand-context-stops ctx))) 356 (define prop-s (keep-properties-only~ result-s)) 357 (define insp (syntax-inspector result-s)) 358 (if primitive? 359 (parsed-primitive-id prop-s binding insp) 360 (parsed-id prop-s binding insp))] 361 [else 362 (define protected-result-s (if protected? 363 (syntax-property result-s 'protected #t) 364 result-s)) 365 (log-expand ctx 'return protected-result-s) 366 protected-result-s])])) 367 368;; ---------------------------------------- 369 370;; Given a macro transformer `t`, apply it --- adding appropriate 371;; scopes to represent the expansion step; the `insp-of-t` inspector 372;; is the inspector of the module that defines `t`, which gives its 373;; privilege for accessing bindings 374(define (apply-transformer t insp-of-t s id ctx binding 375 #:origin-id [origin-id #f]) 376 (performance-region 377 ['expand '_ 'macro] 378 379 (log-expand ctx 'enter-macro s s) 380 (define intro-scope (new-scope 'macro)) 381 (define intro-s (flip-scope s intro-scope)) 382 ;; In a definition context, we need use-site scopes 383 (define use-scopes (maybe-create-use-site-scope ctx binding)) 384 (define use-s (add-scopes intro-s use-scopes)) 385 ;; Prepare to accumulate definition contexts created by the transformer 386 (define def-ctx-scopes (box null)) 387 388 ;; Call the transformer; the current expansion context may be needed 389 ;; for `syntax-local-....` functions, and we may accumulate scopes from 390 ;; definition contexts created by the transformer 391 (define transformed-s 392 (apply-transformer-in-context t use-s ctx insp-of-t 393 intro-scope use-scopes def-ctx-scopes 394 id)) 395 396 ;; Flip the introduction scope 397 (define result-s (flip-scope transformed-s intro-scope)) 398 ;; In a definition context, we need to add the inside-edge scope to 399 ;; any expansion result 400 (define post-s (maybe-add-post-expansion result-s ctx)) 401 ;; Track expansion: 402 (define tracked-s (syntax-track-origin post-s use-s (or origin-id (if (syntax-identifier? s) s (car (syntax-e s)))))) 403 (log-expand ctx 'exit-macro tracked-s post-s) 404 (values tracked-s 405 (accumulate-def-ctx-scopes ctx def-ctx-scopes)))) 406 407;; With all the pre-call scope work done and post-call scope work in 408;; the continuation, actually call the transformer function in the 409;; appropriate context 410(define (apply-transformer-in-context t use-s ctx insp-of-t 411 intro-scope use-scopes def-ctx-scopes 412 id) 413 (log-expand ctx 'macro-pre-x use-s) 414 (define confine-def-ctx-scopes? 415 (not (or (expand-context-only-immediate? ctx) 416 (not (free-id-set-empty-or-just-module*? (expand-context-stops ctx)))))) 417 (define accum-ctx 418 (if (and confine-def-ctx-scopes? 419 (expand-context-def-ctx-scopes ctx) 420 (not (null? (unbox (expand-context-def-ctx-scopes ctx))))) 421 (accumulate-def-ctx-scopes ctx (expand-context-def-ctx-scopes ctx)) 422 ctx)) 423 (define m-ctx (struct*-copy expand-context accum-ctx 424 [current-introduction-scopes (list intro-scope)] 425 [current-use-scopes use-scopes] 426 [def-ctx-scopes 427 (if confine-def-ctx-scopes? 428 ;; Can confine tracking to this call 429 def-ctx-scopes 430 ;; Keep old def-ctx-scopes box, so that we don't 431 ;; lose them at the point where expansion stops 432 (expand-context-def-ctx-scopes ctx))])) 433 (define transformed-s 434 (parameterize ([current-namespace (namespace->namespace-at-phase 435 (expand-context-namespace ctx) 436 (add1 (expand-context-phase ctx)))]) 437 (parameterize-like 438 #:with ([current-expand-context m-ctx] 439 [current-module-code-inspector (or insp-of-t #;(current-module-code-inspector))]) 440 (call-with-continuation-barrier 441 (lambda () 442 ;; Call the transformer! 443 ((transformer->procedure t) use-s)))))) 444 (log-expand ctx 'macro-post-x transformed-s use-s) 445 (unless (syntax? transformed-s) 446 (raise-arguments-error (syntax-e id) 447 "received value from syntax expander was not syntax" 448 "received" transformed-s)) 449 transformed-s) 450 451(define (maybe-create-use-site-scope ctx binding) 452 (cond 453 [(and (root-expand-context-use-site-scopes ctx) 454 (or 455 ;; conservatively use a use-site scope when the origin of the 456 ;; transformer is unknown (as in some uses of 457 ;; syntax-local-apply-transformer) 458 (not binding) 459 (matching-frame? (root-expand-context-frame-id ctx) 460 (binding-frame-id binding)))) 461 ;; We're in a recursive definition context where use-site scopes 462 ;; are needed, so create one, record it, and add to the given 463 ;; syntax 464 (define sc (new-scope 'use-site)) 465 (define b (root-expand-context-use-site-scopes ctx)) 466 (set-box! b (cons sc (unbox b))) 467 468 (define def-ctx-b (expand-context-def-ctx-scopes ctx)) 469 (when def-ctx-b 470 (set-box! def-ctx-b (cons sc (unbox def-ctx-b)))) 471 472 (list sc)] 473 [else null])) 474 475(define (matching-frame? current-frame-id bind-frame-id) 476 (and current-frame-id 477 (or (eq? current-frame-id bind-frame-id) 478 (eq? current-frame-id 'all)))) 479 480(define (maybe-add-post-expansion s ctx) 481 ;; We may be in a definition context where, say, an inside-edge scope 482 ;; needs to be added to any immediate macro expansion; that way, 483 ;; if the macro expands to a definition form, the binding will be 484 ;; in the definition context's scope. The sepcific action depends 485 ;; on the expansion context. 486 (apply-post-expansion (root-expand-context-post-expansion ctx) 487 s)) 488 489(define (accumulate-def-ctx-scopes ctx def-ctx-scopes) 490 ;; Move any accumulated definition-context scopes to the `scopes` 491 ;; list for further expansion: 492 (if (null? (unbox def-ctx-scopes)) 493 ctx 494 (struct*-copy expand-context ctx 495 [scopes (append (unbox def-ctx-scopes) 496 (expand-context-scopes ctx))]))) 497 498;; ---------------------------------------- 499 500;; "Apply" a rename transformer, replacing it with its target. 501(define (apply-rename-transformer t id ctx) 502 (define target-id (rename-transformer-target-in-context t ctx)) 503 ;; Adding a macro-introduction scope doesn't affect scoping at all, but it can affect 504 ;; whether the result is `syntax-original?` 505 (define intro-scope (new-scope 'macro)) 506 (define intro-id (add-scope target-id intro-scope)) 507 (syntax-track-origin (transfer-srcloc intro-id id) id id)) 508 509;; ---------------------------------------- 510 511;; Helper to lookup a binding in an expansion context 512(define (lookup b ctx id 513 #:in [in-s #f] 514 #:out-of-context-as-variable? [out-of-context-as-variable? #f]) 515 (binding-lookup b 516 (expand-context-env ctx) 517 (expand-context-lift-envs ctx) 518 (expand-context-namespace ctx) 519 (expand-context-phase ctx) 520 id 521 #:in in-s 522 #:out-of-context-as-variable? out-of-context-as-variable?)) 523 524(define-syntax-rule (guard-stop id ctx s otherwise ...) 525 (cond 526 [(and (not (free-id-set-empty? (expand-context-stops ctx))) 527 (free-id-set-member? (expand-context-stops ctx) 528 (expand-context-phase ctx) 529 id)) 530 (log-expand* ctx ['resolve id] ['stop/return s]) 531 s] 532 [else 533 otherwise ...])) 534 535(define (substitute-alternate-id s alternate-id) 536 (cond 537 [(not alternate-id) s] 538 [(syntax-identifier? s) (syntax-track-origin alternate-id s)] 539 [else (syntax-track-origin (datum->syntax 540 s 541 (cons alternate-id 542 (cdr (syntax-e s))) 543 s) 544 s)])) 545 546(define (register-variable-referenced-if-local! binding ctx) 547 ;; If the binding's frame has a reference record, then register 548 ;; the use for the purposes of `letrec` splitting 549 (when (and (local-binding? binding) 550 (reference-record? (binding-frame-id binding)) 551 (not (expand-context-parsing-expanded? ctx))) 552 (reference-record-used! (binding-frame-id binding) (local-binding-key binding)))) 553 554;; ---------------------------------------- 555 556;; Expand `s` and capture lifted expressions, combining expanded term 557;; and lifts using `begin` or `let` wrapper 558(define (expand/capture-lifts s ctx 559 #:expand-lifts? [expand-lifts? #f] 560 #:begin-form? [begin-form? #f] 561 #:lift-key [lift-key (generate-lift-key)] 562 #:always-wrap? [always-wrap? #f]) 563 (define context (expand-context-context ctx)) 564 (define phase (expand-context-phase ctx)) 565 (define local? (not begin-form?)) ;; see "[*]" below 566 ;; Expand `s`, but loop to handle lifted expressions 567 (let loop ([s s] [always-wrap? always-wrap?] [ctx ctx]) 568 (define lift-env (and local? (box empty-env))) 569 (define lift-ctx (make-lift-context 570 (if local? 571 (make-local-lift lift-env 572 (root-expand-context-counter ctx) 573 (and (expand-context-normalize-locals? ctx) 'lift)) 574 (make-top-level-lift ctx)) 575 #:module*-ok? (and (not local?) (eq? context 'module)))) 576 (define capture-ctx (struct*-copy expand-context ctx 577 [lift-key #:parent root-expand-context lift-key] 578 [lifts lift-ctx] 579 [lift-envs (if local? 580 (cons lift-env 581 (expand-context-lift-envs ctx)) 582 (expand-context-lift-envs ctx))] 583 [module-lifts (if (or local? 584 (not (memq context '(top-level module)))) 585 (expand-context-module-lifts ctx) 586 lift-ctx)])) 587 (define rebuild-s (keep-properties-only s)) 588 (define exp-s (expand s capture-ctx)) 589 (define lifts (get-and-clear-lifts! (expand-context-lifts capture-ctx))) 590 (define with-lifts-s 591 (cond 592 [(or (pair? lifts) always-wrap?) 593 (cond 594 [(expand-context-to-parsed? ctx) 595 (unless expand-lifts? (error "internal error: to-parsed mode without expanding lifts")) 596 (wrap-lifts-as-parsed-let lifts exp-s rebuild-s ctx (lambda (rhs rhs-ctx) (loop rhs #f rhs-ctx)))] 597 [else 598 (if begin-form? 599 (wrap-lifts-as-begin lifts exp-s phase) 600 (wrap-lifts-as-let lifts exp-s phase))])] 601 [else exp-s])) 602 (cond 603 [(or (not expand-lifts?) (null? lifts) (expand-context-to-parsed? ctx)) 604 ;; Expansion is done 605 with-lifts-s] 606 [else 607 ;; Expand again... 608 (log-expand ctx 'letlift-loop with-lifts-s) 609 (loop with-lifts-s #f ctx)]))) 610 611;; [*] Although `(memq context '(top-level module))` makes more sense 612;; than `(not begin-form?)`, the latter was used historically; the 613;; implementation of `typed/require` currently depends on that 614;; choice, because it expands in 'expression mode to obtain forms 615;; that are splcied into a module context --- leading to an 616;; out-of-context definition error if the historical choice is not 617;; preserved. 618 619;; Expand `s` as a compile-time expression relative to the current 620;; expansion context 621(define (expand-transformer s ctx 622 #:context [context 'expression] 623 #:begin-form? [begin-form? #f] 624 #:expand-lifts? [expand-lifts? #t] 625 #:lift-key [lift-key (generate-lift-key)] 626 #:always-wrap? [always-wrap? #f] 627 #:keep-stops? [keep-stops? #f]) 628 (performance-region 629 ['expand 'transformer] 630 631 (define trans-ctx (context->transformer-context ctx context 632 #:keep-stops? keep-stops?)) 633 (expand/capture-lifts s trans-ctx 634 #:expand-lifts? expand-lifts? 635 #:begin-form? begin-form? 636 #:lift-key lift-key 637 #:always-wrap? always-wrap?))) 638 639(define (context->transformer-context ctx [context 'expression] 640 #:keep-stops? [keep-stops? #f]) 641 (define phase (add1 (expand-context-phase ctx))) 642 (define ns (namespace->namespace-at-phase (expand-context-namespace ctx) 643 phase)) 644 (namespace-visit-available-modules! ns phase) ; redundant? 645 (struct*-copy expand-context ctx 646 [context context] 647 [scopes null] 648 [phase phase] 649 [namespace ns] 650 [env empty-env] 651 [only-immediate? (and keep-stops? (expand-context-only-immediate? ctx))] 652 [stops (if keep-stops? 653 (expand-context-stops ctx) 654 empty-free-id-set)] 655 [def-ctx-scopes #f] 656 [post-expansion #:parent root-expand-context #f])) 657 658;; Expand and evaluate `s` as a compile-time expression, ensuring that 659;; the number of returned values matches the number of target 660;; identifiers; return the expanded form as well as its values 661(define (expand+eval-for-syntaxes-binding who rhs ids ctx 662 #:log-next? [log-next? #t] 663 #:wrap [wrap #f]) 664 (define exp-rhs (expand-transformer rhs (as-named-context ctx ids))) 665 (define phase (add1 (expand-context-phase ctx))) 666 (define parsed-rhs (if (expand-context-to-parsed? ctx) 667 exp-rhs 668 (expand exp-rhs (context->transformer-context 669 (as-to-parsed-context ctx))))) 670 (when log-next? (log-expand ctx 'next)) 671 (values exp-rhs 672 parsed-rhs 673 (eval-for-bindings who 674 ids 675 parsed-rhs 676 phase 677 (namespace->namespace-at-phase 678 (expand-context-namespace ctx) 679 phase) 680 ctx 681 #:wrap wrap))) 682 683;; Expand and evaluate `s` as a compile-time expression, returning 684;; only the compile-time values 685(define (eval-for-syntaxes-binding who rhs ids ctx) 686 (define-values (exp-rhs parsed-rhs vals) 687 (expand+eval-for-syntaxes-binding who rhs ids ctx)) 688 vals) 689 690;; Expand and evaluate `s` as an expression in the given phase; 691;; ensuring that the number of returned values matches the number of 692;; target identifiers; return the values 693(define (eval-for-bindings who ids p phase ns ctx 694 #:wrap [wrap #f]) 695 (define compiled (if (can-direct-eval? p ns (root-expand-context-self-mpi ctx)) 696 #f 697 (compile-single p (make-compile-context 698 #:namespace ns 699 #:phase phase)))) 700 (define vals 701 (call-with-values (lambda () 702 (call-with-continuation-barrier 703 (lambda () 704 (parameterize ([current-namespace ns] 705 [eval-jit-enabled #f]) 706 (parameterize-like 707 #:with ([current-expand-context ctx]) 708 (if compiled 709 (if wrap 710 (wrap (lambda () (eval-single-top compiled ns))) 711 (eval-single-top compiled ns)) 712 (let ([self-mpi (root-expand-context-self-mpi ctx)]) 713 (if wrap 714 (wrap (lambda () (direct-eval p ns self-mpi))) 715 (direct-eval p ns self-mpi))))))))) 716 list)) 717 (unless (or wrap (= (length vals) (length ids))) 718 (raise-bindings-arity-error who ids vals)) 719 vals) 720 721;; ---------------------------------------- 722 723(define (keep-properties-only s) 724 (datum->syntax #f 'props s s)) 725 726;; For cases where we don't actually keep properties, because 727;; the compiler doesn't currently use them: 728(define (keep-properties-only~ s) 729 #f) 730 731;; Drop the `syntax-e` part of `s`, and also drop its scopes when 732;; producing a parsed result, producing a result suitable for use with 733;; `rebuild`, including in a `parsed` record, or to provide a form 734;; name for error reporting. In fact, when producing a parsed value 735;; and `keep-for-parsed?` and `keep-for-error?` are both false, then 736;; keep nothing (because the compiler isn't going to use it). 737;; Dropping references in this way helps the 738;; GC not retain too much of an original syntax object in the process 739;; of expanding it, which can matter for deeply nested expansions. 740(define (keep-as-needed ctx s 741 #:for-track? [for-track? #f] 742 #:keep-for-parsed? [keep-for-parsed? #f] 743 #:keep-for-error? [keep-for-error? #f]) 744 (define d (syntax-e s)) 745 (define keep-e (cond 746 [(symbol? d) d] 747 [(and (pair? d) (syntax-identifier? (car d))) (syntax-e (car d))] 748 [else #f])) 749 (cond 750 [(expand-context-to-parsed? ctx) 751 (and (or keep-for-parsed? keep-for-error?) (datum->syntax #f keep-e s s))] 752 [(and for-track? (pair? d) keep-e) 753 ;; Synthesize form to preserve just source and properties for tracking 754 ;; without affecting the identifier that is kept in 'origin 755 (datum->syntax #f (list (car d)) s s)] 756 [else (datum->syntax s keep-e s s)])) 757 758(define (attach-disappeared-transformer-bindings s trans-idss) 759 (cond 760 [(null? trans-idss) s] 761 [else 762 (syntax-property s 763 'disappeared-binding 764 (append (apply append trans-idss) 765 (or (syntax-property s 'disappeared-binding) 766 null)))])) 767 768;; Generate a fresh binding-layer identity if `ids` contains any 769;; identifiers 770(define (increment-binding-layer ids ctx layer-val) 771 (if (let loop ([ids ids]) 772 (or (identifier? ids) 773 (and (pair? ids) 774 (or (loop (car ids)) (loop (cdr ids)))))) 775 layer-val 776 (expand-context-binding-layer ctx))) 777 778;; Wrap lifted forms in a `let` for a mode where we're generating a 779;; parsed result. The body has already been parsed, and the left-hand 780;; sides already have bindings. We need to parse the right-hand sides 781;; as a series of nested `lets`. 782(define (wrap-lifts-as-parsed-let lifts exp-s rebuild-s ctx parse-rhs) 783 (define idss+keyss+rhss (get-lifts-as-lists lifts)) 784 (let lets-loop ([idss+keyss+rhss idss+keyss+rhss] [rhs-ctx ctx]) 785 (cond 786 [(null? idss+keyss+rhss) exp-s] 787 [else 788 (define ids (caar idss+keyss+rhss)) 789 (define keys (cadar idss+keyss+rhss)) 790 (define rhs (caddar idss+keyss+rhss)) 791 (define exp-rhs (parse-rhs rhs rhs-ctx)) 792 (parsed-let-values 793 rebuild-s 794 (list ids) 795 (list (list keys exp-rhs)) 796 (list 797 (lets-loop (cdr idss+keyss+rhss) 798 (struct*-copy expand-context rhs-ctx 799 [env (for/fold ([env (expand-context-env rhs-ctx)]) ([id (in-list ids)] 800 [key (in-list keys)]) 801 (env-extend env key (local-variable id)))]))))]))) 802 803;; A rename transformer can have a `prop:rename-transformer` property 804;; as a function, and that fnuction might want to use 805;; `syntax-local-value`, etc. 806(define (rename-transformer-target-in-context t ctx) 807 (parameterize-like 808 #:with ([current-expand-context ctx]) 809 (rename-transformer-target t))) 810 811;; In case the rename-transformer has a callback, ensure that the 812;; current expansion context is available while installing a 813;; `free-identifier=?` equivalence 814(define (maybe-install-free=id-in-context! val id phase ctx) 815 (when (rename-transformer? val) 816 (parameterize-like 817 #:with ([current-expand-context ctx]) 818 (maybe-install-free=id! val id phase)))) 819 820;; Transfer the original ID's source location, if any, when expanding 821;; a reference to a rename transformer 822(define (transfer-srcloc new-s old-s) 823 (define srcloc (syntax-srcloc old-s)) 824 (if srcloc 825 (struct-copy syntax new-s 826 [srcloc srcloc]) 827 new-s)) 828