1#lang racket/base 2(require "../common/struct-star.rkt" 3 "../common/set.rkt" 4 "../syntax/syntax.rkt" 5 "../syntax/property.rkt" 6 "../syntax/scope.rkt" 7 "../syntax/taint.rkt" 8 "../syntax/match.rkt" 9 "../namespace/namespace.rkt" 10 "../common/module-path.rkt" 11 "../syntax/binding.rkt" 12 "env.rkt" 13 "free-id-set.rkt" 14 "../syntax/track.rkt" 15 "../syntax/error.rkt" 16 "syntax-id-error.rkt" 17 "dup-check.rkt" 18 "../namespace/core.rkt" 19 "context.rkt" 20 "allowed-context.rkt" 21 "main.rkt" 22 "body.rkt" 23 "set-bang-trans.rkt" 24 "rename-trans.rkt" 25 "reference-record.rkt" 26 "prepare.rkt" 27 "log.rkt" 28 "parsed.rkt" 29 "../compile/correlate.rkt") 30 31;; ---------------------------------------- 32 33;; Common expansion for `lambda` and `case-lambda` 34(define (lambda-clause-expander s formals bodys ctx) 35 (define sc (and (not (expand-context-parsing-expanded? ctx)) 36 (new-scope 'local))) 37 (define phase (expand-context-phase ctx)) 38 ;; Parse and check formal arguments: 39 (define ids (parse-and-flatten-formals formals sc s)) 40 (check-no-duplicate-ids ids phase s #:what "argument name") 41 ;; Bind each argument and generate a corresponding key for the 42 ;; expand-time environment: 43 (define counter (root-expand-context-counter ctx)) 44 (define local-sym (and (expand-context-normalize-locals? ctx) 'arg)) 45 (define keys (for/list ([id (in-list ids)]) 46 (if sc 47 (add-local-binding! id phase counter #:in s #:local-sym local-sym) 48 (existing-binding-key id (expand-context-phase ctx))))) 49 (define body-env (for/fold ([env (expand-context-env ctx)]) ([key (in-list keys)] 50 [id (in-list ids)]) 51 (env-extend env key (local-variable id)))) 52 (define sc-formals (if sc (add-scope formals sc) formals)) 53 (define sc-bodys (if sc 54 (for/list ([body (in-list bodys)]) (add-scope body sc)) 55 bodys)) 56 (log-expand ctx 'lambda-renames sc-formals sc-bodys) 57 ;; Expand the function body: 58 (define body-ctx (struct*-copy expand-context ctx 59 [env body-env] 60 [scopes (if sc 61 (cons sc (expand-context-scopes ctx)) 62 (expand-context-scopes ctx))] 63 [binding-layer (if sc 64 (increment-binding-layer ids ctx sc) 65 (expand-context-binding-layer ctx))] 66 [frame-id #:parent root-expand-context #f])) 67 (define exp-body (if sc 68 (expand-body sc-bodys body-ctx #:source (keep-as-needed ctx s #:keep-for-error? #t)) 69 (for/list ([sc-body (in-list sc-bodys)]) 70 (expand sc-body body-ctx)))) 71 ;; Return formals (with new scope) and expanded body: 72 (values (if (expand-context-to-parsed? ctx) 73 (unflatten-like-formals keys formals) 74 sc-formals) 75 exp-body)) 76 77(add-core-form! 78 'lambda 79 (lambda (s ctx) 80 (log-expand ctx 'prim-lambda s) 81 (define-match m s '(lambda formals body ...+)) 82 (define rebuild-s (keep-as-needed ctx s #:keep-for-parsed? #t)) 83 (define-values (formals body) 84 (lambda-clause-expander s (m 'formals) (m 'body) ctx)) 85 (if (expand-context-to-parsed? ctx) 86 (parsed-lambda rebuild-s formals body) 87 (rebuild 88 rebuild-s 89 `(,(m 'lambda) ,formals ,@body))))) 90 91(add-core-form! 92 'λ 93 ;; A macro: 94 (lambda (s) 95 (define-match m s '(lam-id formals _ ...+)) 96 (define ids (parse-and-flatten-formals (m 'formals) #f s)) 97 (define ctx (get-current-expand-context #:fail-ok? #t)) 98 (define phase (if ctx 99 (expand-context-phase ctx) 100 0)) 101 (check-no-duplicate-ids ids phase s #:what "argument name") 102 (datum->syntax 103 s 104 (cons (datum->syntax (syntax-shift-phase-level core-stx phase) 105 'lambda 106 (m 'lam-id) 107 (m 'lam-id)) 108 (cdr (syntax-e s))) 109 s 110 s))) 111 112(add-core-form! 113 'case-lambda 114 (lambda (s ctx) 115 (log-expand ctx 'prim-case-lambda s) 116 (define-match m s '(case-lambda [formals body ...+] ...)) 117 (define-match cm s '(case-lambda clause ...)) 118 (define rebuild-s (keep-as-needed ctx s #:keep-for-parsed? #t)) 119 (define clauses 120 (for/list ([formals (in-list (m 'formals))] 121 [body (in-list (m 'body))] 122 [clause (in-list (cm 'clause))]) 123 (log-expand ctx 'next) 124 (define rebuild-clause (keep-as-needed ctx clause)) 125 (define-values (exp-formals exp-body) 126 (lambda-clause-expander s formals body ctx)) 127 (if (expand-context-to-parsed? ctx) 128 (list exp-formals exp-body) 129 (rebuild rebuild-clause `[,exp-formals ,@exp-body])))) 130 (if (expand-context-to-parsed? ctx) 131 (parsed-case-lambda rebuild-s clauses) 132 (rebuild 133 rebuild-s 134 `(,(m 'case-lambda) ,@clauses))))) 135 136(define (parse-and-flatten-formals all-formals sc s) 137 (let loop ([formals all-formals]) 138 (cond 139 [(identifier? formals) (list (if sc 140 (add-scope formals sc) 141 formals))] 142 [(syntax? formals) 143 (define p (syntax-e formals)) 144 (cond 145 [(pair? p) (loop p)] 146 [(null? p) null] 147 [else (raise-syntax-error #f "not an identifier" s p)])] 148 [(pair? formals) 149 (unless (identifier? (car formals)) 150 (raise-syntax-error #f "not an identifier" s (car formals))) 151 (cons (if sc 152 (add-scope (car formals) sc) 153 (car formals)) 154 (loop (cdr formals)))] 155 [(null? formals) 156 null] 157 [else 158 (raise-syntax-error "bad argument sequence" s all-formals)]))) 159 160(define (unflatten-like-formals keys formals) 161 (let loop ([keys keys] [formals formals]) 162 (cond 163 [(null? formals) null] 164 [(pair? formals) (cons (car keys) (loop (cdr keys) (cdr formals)))] 165 [(syntax? formals) (loop keys (syntax-e formals))] 166 [else (car keys)]))) 167 168;; ---------------------------------------- 169 170;; Common expansion for `let[rec]-[syntaxes+]values` 171(define (make-let-values-form #:log-tag log-tag 172 #:syntaxes? [syntaxes? #f] 173 #:rec? [rec? #f] 174 #:split-by-reference? [split-by-reference? #f]) 175 (lambda (s ctx) 176 (log-expand ctx log-tag s) 177 (define-match stx-m s #:when syntaxes? 178 '(letrec-syntaxes+values 179 ([(id:trans ...) trans-rhs] ...) 180 ([(id:val ...) val-rhs] ...) 181 body ...+)) 182 (define-match val-m s #:unless syntaxes? 183 '(let-values ([(id:val ...) val-rhs] ...) 184 body ...+)) 185 (define sc (and (not (expand-context-parsing-expanded? ctx)) 186 (new-scope 'local))) 187 (when (and syntaxes? (not sc)) 188 (raise-syntax-error #f 189 "encountered `letrec-syntaxes` in form that should be fully expanded" 190 s)) 191 (define body-sc (and sc rec? (new-scope 'letrec-body))) 192 (define phase (expand-context-phase ctx)) 193 (define frame-id (and syntaxes? 194 (make-reference-record))) ; accumulates info on referenced variables 195 ;; Add the new scope to each binding identifier: 196 (define trans-idss (for/list ([ids (in-list (if syntaxes? (stx-m 'id:trans) null))]) 197 (for/list ([id (in-list ids)]) 198 (add-scope id sc)))) 199 (define trans-rhss (if syntaxes? ; implies rec? 200 (for/list ([rhs (in-list (stx-m 'trans-rhs))]) 201 (add-scope rhs sc)) 202 '())) 203 (define val-idss (let ([val-idss (if syntaxes? (stx-m 'id:val) (val-m 'id:val))]) 204 (if sc 205 (for/list ([ids (in-list val-idss)]) 206 (for/list ([id (in-list ids)]) 207 (add-scope id sc))) 208 val-idss))) 209 (define val-rhss (let ([val-rhss (if syntaxes? (stx-m 'val-rhs) (val-m 'val-rhs))]) 210 (if (and rec? sc) 211 (for/list ([rhs (in-list val-rhss)]) 212 (add-scope rhs sc)) 213 val-rhss))) 214 (define val-clauses ; for syntax tracking 215 (cond 216 [syntaxes? 217 (define-match m s '(_ _ (clause ...) . _)) 218 (m 'clause)] 219 [else 220 (define-match m s '(_ (clause ...) . _)) 221 (m 'clause)])) 222 (check-no-duplicate-ids (list trans-idss val-idss) phase s) 223 ;; Bind each left-hand identifier and generate a corresponding key 224 ;; fo the expand-time environment: 225 (define counter (root-expand-context-counter ctx)) 226 (define local-sym (and (expand-context-normalize-locals? ctx) 'loc)) 227 (define trans-keyss (for/list ([ids (in-list trans-idss)]) 228 (for/list ([id (in-list ids)]) 229 (add-local-binding! id phase counter 230 #:frame-id frame-id #:in s 231 #:local-sym local-sym)))) 232 (define val-keyss (for/list ([ids (in-list val-idss)]) 233 (for/list ([id (in-list ids)]) 234 (if sc 235 (add-local-binding! id phase counter 236 #:frame-id frame-id #:in s 237 #:local-sym local-sym) 238 (existing-binding-key id (expand-context-phase ctx)))))) 239 ;; Add new scope to body: 240 (define bodys (let ([bodys (if syntaxes? (stx-m 'body) (val-m 'body))]) 241 (if sc 242 (for/list ([body (in-list bodys)]) 243 (define new-body (add-scope body sc)) 244 (if rec? 245 (add-scope new-body body-sc) 246 new-body)) 247 bodys))) 248 (log-expand ctx 'letX-renames trans-idss trans-rhss val-idss val-rhss bodys) 249 ;; Evaluate compile-time expressions (if any): 250 (when syntaxes? 251 (log-expand ctx 'prepare-env) 252 (prepare-next-phase-namespace ctx)) 253 (define trans-valss (for/list ([rhs (in-list trans-rhss)] 254 [ids (in-list trans-idss)]) 255 (log-expand* ctx ['next] ['enter-bind]) 256 (define trans-val (eval-for-syntaxes-binding 'letrec-syntaxes+values 257 rhs ids ctx)) 258 (log-expand ctx 'exit-bind) 259 trans-val)) 260 ;; Fill expansion-time environment: 261 (define rec-val-env 262 (for/fold ([env (expand-context-env ctx)]) ([keys (in-list val-keyss)] 263 [ids (in-list val-idss)] 264 #:when #t 265 [key (in-list keys)] 266 [id (in-list ids)]) 267 (env-extend env key (local-variable id)))) 268 (define rec-env (for/fold ([env rec-val-env]) ([keys (in-list trans-keyss)] 269 [vals (in-list trans-valss)] 270 [ids (in-list trans-idss)]) 271 (for/fold ([env env]) ([key (in-list keys)] 272 [val (in-list vals)] 273 [id (in-list ids)]) 274 (maybe-install-free=id-in-context! val id phase ctx) 275 (env-extend env key val)))) 276 (when syntaxes? 277 (log-expand ctx 'next-group)) 278 ;; Expand right-hand sides and body 279 (define expr-ctx (as-expression-context ctx)) 280 (define orig-rrs (expand-context-reference-records expr-ctx)) 281 (define rec-ctx (struct*-copy expand-context expr-ctx 282 [env rec-env] 283 [scopes (if sc 284 (let ([scopes (cons sc (expand-context-scopes ctx))]) 285 (if rec? 286 (cons body-sc scopes) 287 scopes)) 288 (expand-context-scopes ctx))] 289 [reference-records (if split-by-reference? 290 (cons frame-id orig-rrs) 291 orig-rrs)] 292 [binding-layer (if sc 293 (increment-binding-layer 294 (cons trans-idss val-idss) 295 ctx 296 sc) 297 (expand-context-binding-layer ctx))])) 298 (define letrec-values-id 299 (and (not (expand-context-to-parsed? ctx)) 300 (if syntaxes? 301 (core-id 'letrec-values phase) 302 (val-m 'let-values)))) 303 304 (define rebuild-s (keep-as-needed ctx s #:keep-for-error? #t)) 305 (define val-name-idss (if (expand-context-to-parsed? ctx) 306 (for/list ([val-ids (in-list val-idss)]) 307 (for/list ([val-id (in-list val-ids)]) 308 (datum->syntax #f (syntax-e val-id) val-id val-id))) 309 val-idss)) 310 311 (define (get-body) 312 (cond 313 [(expand-context-parsing-expanded? ctx) 314 (for/list ([body (in-list bodys)]) 315 (expand body rec-ctx))] 316 [else 317 (define body-ctx (struct*-copy expand-context rec-ctx 318 [reference-records orig-rrs])) 319 (expand-body bodys (as-tail-context body-ctx #:wrt ctx) #:source rebuild-s)])) 320 (define result-s 321 (cond 322 [(not split-by-reference?) 323 (define clauses 324 (for/list ([ids (in-list val-name-idss)] 325 [keys (in-list val-keyss)] 326 [rhs (in-list val-rhss)] 327 [clause (in-list val-clauses)]) 328 (log-expand ctx 'next) 329 (define exp-rhs (expand rhs (if rec? 330 (as-named-context rec-ctx ids) 331 (as-named-context expr-ctx ids)))) 332 (if (expand-context-to-parsed? ctx) 333 (list keys exp-rhs) 334 (datum->syntax #f `[,ids ,exp-rhs] clause clause)))) 335 (define exp-body (get-body)) 336 (when frame-id 337 (reference-record-clear! frame-id)) 338 (if (expand-context-to-parsed? ctx) 339 (if rec? 340 (parsed-letrec-values rebuild-s val-name-idss clauses exp-body) 341 (parsed-let-values rebuild-s val-name-idss clauses exp-body)) 342 (rebuild 343 rebuild-s 344 `(,letrec-values-id ,clauses ,@exp-body)))] 345 [else 346 (expand-and-split-bindings-by-reference 347 val-idss val-keyss val-rhss val-clauses 348 #:split? #t 349 #:frame-id frame-id #:ctx rec-ctx 350 #:source rebuild-s #:had-stxes? syntaxes? 351 #:get-body get-body #:track? #t)])) 352 353 (if (expand-context-to-parsed? ctx) 354 result-s 355 (attach-disappeared-transformer-bindings result-s trans-idss)))) 356 357(add-core-form! 358 'let-values 359 (make-let-values-form #:log-tag 'prim-let-values)) 360 361(add-core-form! 362 'letrec-values 363 (make-let-values-form #:rec? #t #:log-tag 'prim-letrec-values)) 364 365(add-core-form! 366 'letrec-syntaxes+values 367 (make-let-values-form #:syntaxes? #t #:rec? #t #:split-by-reference? #t 368 #:log-tag 'prim-letrec-syntaxes+values)) 369 370;; ---------------------------------------- 371 372(add-core-form! 373 '#%stratified-body 374 (lambda (s ctx) 375 (log-expand ctx 'prim-#%stratified s) 376 (define-match m s '(#%stratified-body body ...+)) 377 (define rebuild-s (keep-as-needed ctx s #:keep-for-error? #t)) 378 (define exp-body (expand-body (m 'body) ctx #:stratified? #t #:source rebuild-s)) 379 (if (expand-context-to-parsed? ctx) 380 (parsed-begin rebuild-s exp-body) 381 (rebuild 382 rebuild-s 383 (if (null? (cdr exp-body)) 384 (car exp-body) 385 `(,(core-id 'begin (expand-context-phase ctx)) 386 ,@exp-body)))))) 387 388;; ---------------------------------------- 389 390(add-core-form! 391 '#%datum 392 (lambda (s ctx) 393 (log-expand ctx 'prim-#%datum s) 394 (define-match m s '(#%datum . datum)) 395 (define datum (m 'datum)) 396 (when (and (syntax? datum) 397 (keyword? (syntax-e datum))) 398 (raise-syntax-error '#%datum "keyword misused as an expression" #f datum)) 399 (define phase (expand-context-phase ctx)) 400 (if (and (expand-context-to-parsed? ctx) 401 (free-id-set-empty? (expand-context-stops ctx))) 402 (parsed-quote (keep-properties-only~ s) (syntax->datum datum)) 403 (syntax-track-origin (rebuild s 404 (list (core-id 'quote phase) 405 datum) 406 #:track? #f) 407 s 408 (m '#%datum))))) 409 410;; '#%kernel `#%app` treats an empty combination as a literal null 411(add-core-form! 412 '#%app 413 (lambda (s ctx) 414 (log-expand ctx 'prim-#%app s) 415 (define-match m s '(#%app e ...)) 416 (define es (m 'e)) 417 (cond 418 [(null? es) 419 (define phase (expand-context-phase ctx)) 420 (if (expand-context-to-parsed? ctx) 421 (parsed-quote (keep-properties-only~ s) null) 422 (rebuild 423 s 424 (list (core-id 'quote phase) 425 null)))] 426 [else 427 (define keep-for-parsed? keep-source-locations?) 428 (define rebuild-s (keep-as-needed ctx s #:keep-for-parsed? keep-for-parsed?)) 429 (define prefixless (cdr (syntax-e s))) 430 (define rebuild-prefixless (and (syntax? prefixless) 431 (keep-as-needed ctx prefixless #:keep-for-parsed? keep-for-parsed?))) 432 (define expr-ctx (as-expression-context ctx)) 433 (log-expand expr-ctx 'next) 434 (define rest-es (cdr es)) 435 (define exp-rator (expand (car es) expr-ctx)) 436 (define exp-es (for/list ([e (in-list rest-es)]) 437 (log-expand expr-ctx 'next) 438 (expand e expr-ctx))) 439 (cond 440 [(expand-context-to-parsed? ctx) 441 (parsed-app (or rebuild-prefixless rebuild-s) exp-rator exp-es)] 442 [else 443 (define es (let ([exp-es (cons exp-rator exp-es)]) 444 (if rebuild-prefixless 445 (rebuild rebuild-prefixless exp-es) 446 exp-es))) 447 (rebuild rebuild-s (cons (m '#%app) es))])]))) 448 449 450(add-core-form! 451 'quote 452 (lambda (s ctx) 453 (log-expand ctx 'prim-quote #f) 454 (define-match m s '(quote datum)) 455 (if (expand-context-to-parsed? ctx) 456 (parsed-quote (keep-properties-only~ s) (syntax->datum (m 'datum))) 457 s))) 458 459(add-core-form! 460 'quote-syntax 461 (lambda (s ctx) 462 (log-expand ctx 'prim-quote-syntax s) 463 (define-match m-local s #:try '(quote-syntax datum #:local)) 464 (define-match m s #:unless (m-local) '(quote-syntax datum)) 465 (cond 466 [(m-local) 467 ;; #:local means don't prune, and it counts as a reference to 468 ;; all variables for letrec splitting 469 (reference-records-all-used! (expand-context-reference-records ctx)) 470 (define-match m-kw s '(_ _ kw)) 471 (if (expand-context-to-parsed? ctx) 472 (parsed-quote-syntax (keep-properties-only~ s) (m-local 'datum)) 473 (rebuild 474 s 475 `(,(m-local 'quote-syntax) ,(m-local 'datum) ,(m-kw 'kw))))] 476 [else 477 ;; otherwise, prune scopes up to transformer boundary: 478 (define use-site-scopes (root-expand-context-use-site-scopes ctx)) 479 (define datum-s (remove-scopes (remove-scopes (m 'datum) (expand-context-scopes ctx)) 480 (if use-site-scopes (unbox use-site-scopes) '()))) 481 (if (and (expand-context-to-parsed? ctx) 482 (free-id-set-empty? (expand-context-stops ctx))) 483 (parsed-quote-syntax (keep-properties-only~ s) datum-s) 484 (rebuild 485 s 486 `(,(m 'quote-syntax) 487 ,datum-s)))]))) 488 489(add-core-form! 490 'if 491 (lambda (s ctx) 492 (log-expand ctx 'prim-if s) 493 (define-match bad-m s #:try '(_ _ _)) 494 (when (bad-m) (raise-syntax-error #f "missing an \"else\" expression" s)) 495 (define-match m s '(if tst thn els)) 496 (define expr-ctx (as-expression-context ctx)) 497 (define tail-ctx (as-tail-context expr-ctx #:wrt ctx)) 498 (define rebuild-s (keep-as-needed ctx s)) 499 (define exp-tst (expand (m 'tst) expr-ctx)) 500 (log-expand ctx 'next) 501 (define exp-thn (expand (m 'thn) tail-ctx)) 502 (log-expand ctx 'next) 503 (define exp-els (expand (m 'els) tail-ctx)) 504 (if (expand-context-to-parsed? ctx) 505 (parsed-if rebuild-s exp-tst exp-thn exp-els) 506 (rebuild 507 rebuild-s 508 (list (m 'if) exp-tst exp-thn exp-els))))) 509 510(add-core-form! 511 'with-continuation-mark 512 (lambda (s ctx) 513 (log-expand ctx 'prim-with-continuation-mark s) 514 (define-match m s '(with-continuation-mark key val body)) 515 (define expr-ctx (as-expression-context ctx)) 516 (define rebuild-s (keep-as-needed ctx s)) 517 (define exp-key (expand (m 'key) expr-ctx)) 518 (log-expand ctx 'next) 519 (define exp-val (expand (m 'val) expr-ctx)) 520 (log-expand ctx 'next) 521 (define exp-body (expand (m 'body) (as-tail-context expr-ctx #:wrt ctx))) 522 (if (expand-context-to-parsed? ctx) 523 (parsed-with-continuation-mark rebuild-s exp-key exp-val exp-body) 524 (rebuild 525 rebuild-s 526 (list (m 'with-continuation-mark) exp-key exp-val exp-body))))) 527 528(define (make-begin log-tag parsed-begin 529 #:last-is-tail? last-is-tail?) 530 (lambda (s ctx) 531 (log-expand ctx log-tag s) 532 (define-match m s '(begin e ...+)) 533 (define expr-ctx (if last-is-tail? 534 (as-begin-expression-context ctx) 535 (as-expression-context ctx))) 536 (define rebuild-s (keep-as-needed ctx s)) 537 (define exp-es 538 (let loop ([es (m 'e)]) 539 (cond 540 [(null? es) null] 541 [else 542 (define rest-es (cdr es)) 543 (log-expand ctx 'next) 544 (cons (expand (car es) (if (and last-is-tail? (null? rest-es)) 545 (as-tail-context expr-ctx #:wrt ctx) 546 expr-ctx)) 547 (loop rest-es))]))) 548 (if (expand-context-to-parsed? ctx) 549 (parsed-begin rebuild-s exp-es) 550 (rebuild 551 rebuild-s 552 (cons (m 'begin) exp-es))))) 553 554(add-core-form! 555 'begin 556 (let ([nonempty-begin (make-begin 'prim-begin parsed-begin #:last-is-tail? #t)]) 557 (lambda (s ctx) 558 ;; Empty `begin` allowed in 'top-level and 'module contexts, 559 ;; which might get here via `local-expand`: 560 (define context (expand-context-context ctx)) 561 (cond 562 [(or (eq? context 'top-level) (eq? context 'module)) 563 (define-match m s #:try '(begin)) 564 (if (m) 565 (if (expand-context-to-parsed? ctx) 566 (parsed-begin (keep-as-needed ctx s) '()) 567 s) 568 (nonempty-begin s ctx))] 569 [else 570 (nonempty-begin s ctx)])))) 571 572(add-core-form! 573 'begin0 574 (make-begin 'prim-begin0 parsed-begin0 #:last-is-tail? #f)) 575 576(define (register-eventual-variable!? id ctx) 577 (cond 578 [(and (expand-context-need-eventually-defined ctx) 579 ((expand-context-phase ctx) . >= . 1)) 580 ;; In top level or `begin-for-syntax`, encountered a reference to a 581 ;; variable that might be defined later; record it for later checking 582 (hash-update! (expand-context-need-eventually-defined ctx) 583 (expand-context-phase ctx) 584 (lambda (l) (cons id l)) 585 null) 586 #t] 587 [else #f])) 588 589;; returns whether the binding is to a primitive 590(define (check-top-binding-is-variable ctx b id s) 591 (define-values (t primitive? insp-of-t protected?) 592 (lookup b ctx id 593 #:in s 594 #:out-of-context-as-variable? (expand-context-in-local-expand? ctx))) 595 (unless (variable? t) 596 (raise-syntax-error #f "identifier does not refer to a variable" id s)) 597 primitive?) 598 599(add-core-form! 600 '#%top 601 (lambda (s ctx [implicit-omitted? #f]) 602 (log-expand ctx 'prim-#%top s) 603 (define id (cond 604 [implicit-omitted? 605 ;; As a special favor to `local-expand`, the expander 606 ;; has avoided making `#%top` explicit 607 s] 608 [else 609 (define-match m s '(#%top . id)) 610 (m 'id)])) 611 (define b (resolve+shift id (expand-context-phase ctx) 612 #:ambiguous-value 'ambiguous)) 613 (cond 614 [(eq? b 'ambiguous) 615 (raise-ambiguous-error id ctx)] 616 [(and b 617 (module-binding? b) 618 (eq? (module-binding-module b) (root-expand-context-self-mpi ctx))) 619 ;; Within a module, check that binding is a variable, not syntax: 620 (unless (expand-context-allow-unbound? ctx) 621 (check-top-binding-is-variable ctx b id s)) 622 ;; Allow `#%top` in a module or top-level where it refers to the same 623 ;; thing that the identifier by itself would refer to; in that case 624 ;; `#%top` can be stripped within a module 625 (if (expand-context-to-parsed? ctx) 626 (parsed-id id b #f) 627 (cond 628 [(top-level-module-path-index? (module-binding-module b)) s] 629 [else id]))] 630 [(local-binding? b) 631 ;; In all contexts, including the top level, count as unbound 632 (raise-unbound-syntax-error #f "unbound identifier" id #f null 633 (syntax-debug-info-string id ctx))] 634 [(register-eventual-variable!? id ctx) 635 ;; Must be in a module, and we'll check the binding later, so strip `#%top`: 636 (if (expand-context-to-parsed? ctx) 637 (parsed-id id b #f) 638 id)] 639 [else 640 (cond 641 [(not (expand-context-allow-unbound? ctx)) 642 ;; In a module, unbound or out of context: 643 (raise-unbound-syntax-error #f "unbound identifier" id #f null 644 (syntax-debug-info-string id ctx))] 645 [else 646 ;; At the top level: 647 (define tl-id (add-scope id (root-expand-context-top-level-bind-scope ctx))) 648 (define tl-b (resolve tl-id (expand-context-phase ctx))) 649 (cond 650 [tl-b 651 ;; Expand to a reference to a top-level variable, instead of 652 ;; a required variable; don't include the temporary 653 ;; binding scope in an expansion, though, in the same way that 654 ;; `define-values` expands without it 655 (if (expand-context-to-parsed? ctx) 656 (parsed-top-id tl-id tl-b #f) 657 (cond 658 [implicit-omitted? id] 659 [else 660 (define-match m s '(#%top . id)) 661 (rebuild s (cons (m '#%top) id))]))] 662 [else (if (expand-context-to-parsed? ctx) 663 (parsed-top-id id b #f) 664 s)])])]))) 665 666(add-core-form! 667 'set! 668 (lambda (s ctx) 669 (log-expand ctx 'prim-set! s) 670 (define-match m s '(set! id rhs)) 671 (define orig-id (m 'id)) 672 (let rename-loop ([id orig-id] [from-rename? #f]) 673 (define binding (resolve+shift id (expand-context-phase ctx) 674 #:ambiguous-value 'ambiguous 675 #:immediate? #t)) 676 (when (eq? binding 'ambiguous) 677 (raise-ambiguous-error id ctx)) 678 (define-values (t primitive? insp protected?) (if binding 679 (lookup binding ctx s) 680 (values #f #f #f #f))) 681 (log-expand ctx 'resolve id) 682 (cond 683 [(or (variable? t) 684 (and (not binding) 685 (or (register-eventual-variable!? id ctx) 686 (expand-context-allow-unbound? ctx)))) 687 (when (and (module-binding? binding) 688 (not (inside-module-context? (module-binding-module binding) 689 (root-expand-context-self-mpi ctx)))) 690 (raise-syntax-error #f "cannot mutate module-required identifier" s id)) 691 (log-expand ctx 'next) 692 (register-variable-referenced-if-local! binding ctx) 693 (define rebuild-s (keep-as-needed ctx s)) 694 (define exp-rhs (expand (m 'rhs) (as-expression-context ctx))) 695 (if (expand-context-to-parsed? ctx) 696 (parsed-set! rebuild-s (parsed-id id binding #f) exp-rhs) 697 (rebuild 698 rebuild-s 699 (list (m 'set!) 700 (substitute-variable id t #:no-stops? (free-id-set-empty-or-just-module*? (expand-context-stops ctx))) 701 exp-rhs)))] 702 [(not binding) 703 (raise-unbound-syntax-error #f "unbound identifier" s id null 704 (syntax-debug-info-string id ctx))] 705 [(set!-transformer? t) 706 (cond 707 [(not-in-this-expand-context? t ctx) 708 (expand (avoid-current-expand-context (substitute-set!-rename s (m 'set!) (m 'rhs) id from-rename? ctx) t ctx) 709 ctx)] 710 [else 711 (define-values (exp-s re-ctx) 712 (apply-transformer t insp s orig-id ctx binding #:origin-id orig-id)) 713 (cond 714 [(expand-context-just-once? ctx) exp-s] 715 [else (expand exp-s re-ctx)])])] 716 [(rename-transformer? t) 717 (cond 718 [(not-in-this-expand-context? t ctx) 719 (expand (avoid-current-expand-context (substitute-set!-rename s (m 'set!) (m 'rhs) id from-rename? ctx) t ctx) 720 ctx)] 721 [else (rename-loop (apply-rename-transformer t id ctx) #t)])] 722 [else 723 (raise-syntax-error #f "cannot mutate syntax identifier" s id)])))) 724 725(define (substitute-set!-rename s set!-id id rhs-s from-rename? ctx) 726 (cond 727 [from-rename? (datum->syntax s (list set!-id id rhs-s) s s)] 728 [else s])) 729 730(add-core-form! 731 '#%variable-reference 732 (lambda (s ctx) 733 (log-expand ctx 'prim-#%variable-reference s) 734 (define-match id-m s #:try '(#%variable-reference id)) 735 (define-match top-m s #:unless (id-m) #:try '(#%variable-reference (#%top . id))) 736 (define-match empty-m s #:unless (or (id-m) (top-m)) '(#%variable-reference)) 737 (cond 738 [(or (id-m) (top-m)) 739 (when (top-m) 740 (define phase (expand-context-phase ctx)) 741 (unless (and (identifier? (top-m '#%top)) 742 (free-identifier=? (top-m '#%top) (core-id '#%top phase) phase phase)) 743 (raise-syntax-error #f "bad syntax" s))) 744 (define var-id (if (id-m) (id-m 'id) (top-m 'id))) 745 (define binding (resolve+shift var-id (expand-context-phase ctx) 746 #:ambiguous-value 'ambiguous)) 747 (when (eq? binding 'ambiguous) 748 (raise-ambiguous-error var-id ctx)) 749 (unless (and (or binding 750 (expand-context-allow-unbound? ctx)) 751 (not (and (top-m) (local-binding? binding)))) 752 (raise-unbound-syntax-error #f "unbound identifier" s var-id null 753 (syntax-debug-info-string var-id ctx))) 754 (define primitive? 755 (cond 756 [(or (not binding) 757 (and (expand-context-allow-unbound? ctx) 758 (top-m))) 759 #f] 760 [else 761 (check-top-binding-is-variable ctx binding var-id s)])) 762 (if (expand-context-to-parsed? ctx) 763 (parsed-#%variable-reference (keep-properties-only~ s) 764 (cond 765 [(top-m) (parsed-top-id var-id binding #f)] 766 [primitive? (parsed-primitive-id var-id binding #f)] 767 [else (parsed-id var-id binding #f)])) 768 s)] 769 [else 770 (if (expand-context-to-parsed? ctx) 771 (parsed-#%variable-reference (keep-properties-only~ s) #f) 772 s)]))) 773 774(add-core-form! 775 '#%expression 776 (lambda (s ctx) 777 (log-expand ctx 'prim-#%expression s) 778 (define-match m s '(#%expression e)) 779 (define rebuild-s (keep-as-needed ctx s #:for-track? #t)) 780 (define exp-e (expand (m 'e) (as-tail-context (as-expression-context ctx) 781 #:wrt ctx))) 782 (if (expand-context-to-parsed? ctx) 783 exp-e 784 (cond 785 [(or (and (expand-context-in-local-expand? ctx) 786 (expand-context-keep-#%expression? ctx)) 787 (eq? 'top-level (expand-context-context ctx))) 788 (rebuild 789 rebuild-s 790 `(,(m '#%expression) ,exp-e))] 791 [else 792 (define result-s (syntax-track-origin exp-e rebuild-s)) 793 (log-expand ctx 'tag result-s) 794 result-s])))) 795 796;; ---------------------------------------- 797 798;; Historically in '#%kernel, should be moved out 799(add-core-form! 800 'unquote 801 (lambda (s ctx) 802 (raise-syntax-error #f "not in quasiquote" s))) 803(add-core-form! 804 'unquote-splicing 805 (lambda (s ctx) 806 (raise-syntax-error #f "not in quasiquote" s))) 807