reductions.rkt (27753B)
1 #lang racket/base 2 (require (for-syntax racket/base) 3 racket/match 4 racket/format 5 syntax/stx 6 "../util/eomap.rkt" 7 "deriv-util.rkt" 8 "deriv.rkt" 9 "reductions-engine.rkt") 10 11 (provide reductions 12 reductions+) 13 14 ;; Reductions 15 16 ;; reductions : WDeriv -> ReductionSequence 17 (define (reductions d) 18 (let-values ([(steps binders definites estx exn) (reductions+ d)]) 19 steps)) 20 21 ;; Binders = hasheq[identifier => phase-level] 22 ;; Definites = eomap[identifier => phase-level] 23 24 ;; reductions+ : WDeriv -> (list-of step) Binders Definites ?stx ?exn 25 (define (reductions+ d) 26 (parameterize ((current-definites (empty-eomap)) 27 (current-binders #hasheq()) 28 (current-frontier null) 29 (hides-flags (list (box #f))) 30 (sequence-number 0)) 31 (RScase ((Expr d) (wderiv-e1 d) (wderiv-e1 d) #f null) 32 (lambda (steps stx vstx s) 33 (values (reverse steps) (current-binders) (current-definites) vstx #f)) 34 (lambda (steps exn) 35 (values (reverse steps) (current-binders) (current-definites) #f exn))))) 36 37 ;; Syntax 38 39 (define-syntax-rule (match/count x clause ...) 40 (begin (sequence-number (add1 (sequence-number))) 41 (let ([v x]) 42 (match v 43 clause ... 44 [_ (error 'match "failed to match ~e at line ~s" v (line-of x))])))) 45 46 (define-syntax (line-of stx) 47 (syntax-case stx () 48 [(line-of x) #`(quote #,(syntax-line #'x))])) 49 50 ;; Derivations => Steps 51 52 ;; Expr : Deriv -> RST 53 (define (Expr d) 54 (match/count d 55 [(Wrap deriv (e1 e2)) 56 (R [#:pattern ?form] 57 [#:let transparent-stx (hash-ref opaque-table (syntax-e #'?form) #f)] 58 [#:when transparent-stx 59 [#:set-syntax transparent-stx]] 60 [#:expect-syntax e1 (list d)] 61 [#:when (base? d) 62 [#:learn (or (base-resolves d) null)]] 63 [#:seek-check] 64 [Expr* ?form d] 65 [#:when (not (current-pass-hides?)) 66 [#:set-syntax e2]])] 67 [#f 68 (R [#:seek-check] 69 => (Expr* d))])) 70 71 (define (Expr* d) 72 (match d 73 ;; Primitives 74 [(Wrap p:variable (e1 e2 rs ?1)) 75 (R [#:learn (list e2)] 76 [#:when (or (not (identifier? e1)) 77 (not (bound-identifier=? e1 e2))) 78 [#:walk e2 'resolve-variable]])] 79 [(Wrap p:module (e1 e2 rs ?1 prep tag rename check tag2 ?3 body shift)) 80 (R [#:hide-check rs] 81 [! ?1] 82 [#:pattern ?form] 83 [PrepareEnv ?form prep] 84 [#:pattern (?module ?name ?language . ?body-parts)] 85 [#:when tag 86 [#:in-hole ?body-parts 87 [#:walk (list tag) 'tag-module-begin]]] 88 [#:pattern (?module ?name ?language ?body)] 89 [#:rename ?body rename] 90 [#:pass1] 91 [#:when check 92 [Expr ?body check]] 93 [#:when tag2 94 [#:in-hole ?body 95 [#:walk tag2 'tag-module-begin]]] 96 [#:pass2] 97 [! ?3] 98 [Expr ?body body] 99 [#:pattern ?form] 100 [#:rename ?form shift])] 101 [(Wrap p:#%module-begin (e1 e2 rs ?1 me body ?2 subs)) 102 (R [! ?1] 103 [#:pattern ?form] 104 [#:rename ?form me] 105 [#:pattern (?module-begin . ?forms)] 106 [ModuleBegin/Phase ?forms body] 107 [! ?2] 108 [Submodules ?forms subs])] 109 [(Wrap p:define-syntaxes (e1 e2 rs ?1 prep rhs locals)) 110 (R [! ?1] 111 [#:pattern ?form] 112 [PrepareEnv ?form prep] 113 [#:pattern (?define-syntaxes ?vars ?rhs)] 114 [#:binders #'?vars] 115 [Expr/PhaseUp ?rhs rhs] 116 [LocalActions ?rhs locals])] 117 [(Wrap p:define-values (e1 e2 rs ?1 rhs)) 118 (R [! ?1] 119 [#:pattern (?define-values ?vars ?rhs)] 120 [#:binders #'?vars] 121 [#:when rhs 122 [Expr ?rhs rhs]])] 123 [(Wrap p:#%expression (e1 e2 rs ?1 inner #f)) 124 (R [! ?1] 125 [#:pattern (?expr-kw ?inner)] 126 [Expr ?inner inner])] 127 [(Wrap p:#%expression (e1 e2 rs ?1 inner untag)) 128 (R [! ?1] 129 [#:pattern (?expr-kw ?inner)] 130 [#:pass1] 131 [Expr ?inner inner] 132 [#:pattern ?form] 133 [#:let oldform #'?form] 134 [#:with-visible-form 135 [#:left-foot] 136 [#:set-syntax (stx-car (stx-cdr #'?form))] 137 [#:step 'macro]] ;; FIXME: 'untag-expr 138 [#:pass2] 139 [#:set-syntax (stx-car (stx-cdr oldform))] 140 [#:rename ?form untag])] 141 [(Wrap p:if (e1 e2 rs ?1 test then else)) 142 (R [! ?1] 143 [#:pattern (?if TEST THEN ELSE)] 144 [Expr TEST test] 145 [Expr THEN then] 146 [Expr ELSE else])] 147 [(Wrap p:wcm (e1 e2 rs ?1 key mark body)) 148 (R [! ?1] 149 [#:pattern (?wcm KEY MARK BODY)] 150 [Expr KEY key] 151 [Expr MARK mark] 152 [Expr BODY body])] 153 [(Wrap p:begin (e1 e2 rs ?1 lderiv)) 154 (R [! ?1] 155 [#:pattern (?begin . ?lderiv)] 156 [List ?lderiv lderiv])] 157 [(Wrap p:begin0 (e1 e2 rs ?1 first lderiv)) 158 (R [! ?1] 159 [#:pattern (?begin0 FIRST . LDERIV)] 160 [Expr FIRST first] 161 [List LDERIV lderiv])] 162 [(Wrap p:#%app (e1 e2 rs ?1 lderiv)) 163 (R [! ?1] 164 [#:pattern (?app . LDERIV)] 165 [#:if lderiv 166 ([List LDERIV lderiv]) 167 ([#:walk e2 'macro])])] 168 [(Wrap p:lambda (e1 e2 rs ?1 renames body)) 169 (R [! ?1] 170 [#:pattern (?lambda ?formals . ?body)] 171 [#:rename (?formals . ?body) renames 'rename-lambda] 172 [#:binders #'?formals] 173 [Block ?body body])] 174 [(Wrap p:case-lambda (e1 e2 rs ?1 clauses)) 175 (R [! ?1] 176 [#:pattern (?case-lambda . ?clauses)] 177 [CaseLambdaClauses ?clauses clauses])] 178 [(Wrap p:let-values (e1 e2 rs ?1 renames rhss body)) 179 (R [! ?1] 180 [#:pattern (?let-values ([?vars ?rhs] ...) . ?body)] 181 [#:rename (((?vars ?rhs) ...) . ?body) renames 'rename-let-values] 182 [#:binders #'(?vars ...)] 183 [Expr (?rhs ...) rhss] 184 [Block ?body body])] 185 [(Wrap p:letrec-values (e1 e2 rs ?1 renames rhss body)) 186 (R [! ?1] 187 [#:pattern (?letrec-values ([?vars ?rhs] ...) . ?body)] 188 [#:rename (((?vars ?rhs) ...) . ?body) renames 'rename-letrec-values] 189 [#:binders #'(?vars ...)] 190 [Expr (?rhs ...) rhss] 191 [Block ?body body])] 192 [(Wrap p:letrec-syntaxes+values 193 (e1 e2 rs ?1 srenames prep srhss vrenames vrhss body tag)) 194 (R [! ?1] 195 [#:pattern ?form] 196 [PrepareEnv ?form prep] 197 [#:pass1] 198 [#:pattern (?lsv ([?svars ?srhs] ...) ([?vvars ?vrhs] ...) . ?body)] 199 [#:rename (((?svars ?srhs) ...) ((?vvars ?vrhs) ...) . ?body) 200 srenames 201 'rename-lsv] 202 [#:binders #'(?svars ... ?vvars ...)] 203 [#:when (pair? srhss) ;; otherwise, we're coming from a block expansion 204 [BindSyntaxes (?srhs ...) srhss]] 205 ;; If vrenames is #f, no var bindings to rename 206 [#:when vrenames 207 [#:rename (((?vvars ?vrhs) ...) . ?body) vrenames 'rename-lsv] 208 [#:binders #'(?vvars ...)]] 209 [Expr (?vrhs ...) vrhss] 210 [Block ?body body] 211 [#:pass2] 212 [#:pattern ?form] 213 [#:when tag 214 [#:walk tag 'lsv-remove-syntax]])] 215 [(Wrap p:#%datum (e1 e2 rs ?1)) 216 (R [! ?1] 217 [#:hide-check rs] 218 [#:walk e2 'macro])] 219 [(Wrap p:#%top (e1 e2 rs ?1)) 220 (R [! ?1] 221 [#:pattern ?form] 222 [#:learn 223 (syntax-case #'?form () 224 [(?top . ?var) (identifier? #'?var) (list #'?var)] 225 [?var (identifier? #'?var) (list #'?var)] 226 [_ (error 'macro-debugger "#%top has wrong form: ~s\n" #'?form)])])] 227 228 [(Wrap p:provide (e1 e2 rs ?1 inners ?2)) 229 (let ([wrapped-inners (map expr->local-action inners)]) 230 (R [! ?1] 231 [#:pattern ?form] 232 [#:pass1] 233 [#:left-foot] 234 [LocalActions ?form wrapped-inners] 235 [! ?2] 236 [#:pass2] 237 [#:set-syntax e2] 238 [#:step 'provide] 239 [#:set-syntax e2]))] 240 241 [(Wrap p:require (e1 e2 rs ?1 locals)) 242 (R [! ?1] 243 [#:pattern ?form] 244 [LocalActions ?form locals])] 245 246 [(Wrap p:#%stratified-body (e1 e2 rs ?1 bderiv)) 247 (R [! ?1] 248 [#:pass1] 249 [#:pattern (?sb . ?body)] 250 [Block ?body bderiv] 251 [#:pass2] 252 [#:hide-check rs] 253 [#:pattern ?form] 254 [#:walk e2 'macro])] 255 256 [(Wrap p:submodule* (e1 e2 rs ?1)) 257 (R [! ?1])] 258 [(Wrap p:submodule (e1 e2 rs ?1 exp)) 259 (R [! ?1] 260 [#:pattern ?form] 261 [Expr ?form exp])] 262 263 [(Wrap p:stop (e1 e2 rs ?1)) 264 (R [! ?1])] 265 266 ;; The rest of the automatic primitives 267 [(Wrap p::STOP (e1 e2 rs ?1)) 268 (R [! ?1])] 269 270 [(Wrap p:set!-macro (e1 e2 rs ?1 deriv)) 271 (R [! ?1] 272 [#:pattern ?form] 273 [Expr ?form deriv])] 274 [(Wrap p:set! (e1 e2 rs ?1 id-rs ?2 rhs)) 275 (R [! ?1] 276 [#:pattern (?set! ?var ?rhs)] 277 [#:learn id-rs] 278 [! ?2] 279 [Expr ?rhs rhs])] 280 281 [(Wrap p:begin-for-syntax (e1 e2 rs ?1 prep body locals)) 282 (R [! ?1] 283 [#:pattern ?form] 284 [PrepareEnv ?form prep] 285 [#:pattern (?bfs . ?forms)] 286 [#:parameterize ((phase (add1 (phase)))) 287 [#:if (module-begin/phase? body) 288 [[ModuleBegin/Phase ?forms body]] 289 [[BeginForSyntax ?forms body]]]] 290 [LocalActions ?forms locals])] 291 292 ;; Macros 293 [(Wrap mrule (e1 e2 rs ?1 me1 locals me2 ?2 etx next)) 294 (R [! ?1] 295 [#:pattern ?form] 296 [#:hide-check rs] 297 [#:learn rs] 298 [#:pass1] 299 [#:left-foot] 300 [#:rename/mark ?form e1 me1] ;; MARK 301 [LocalActions ?form locals] 302 [! ?2] 303 [#:pass2] 304 [#:set-syntax me2] 305 [#:rename/unmark ?form me2 etx] ;; UNMARK 306 [#:step 'macro] 307 [#:set-syntax etx] 308 [Expr ?form next])] 309 310 [(Wrap tagrule (e1 e2 tagged-stx next)) 311 (R [#:pattern ?form] 312 [#:hide-check (list (stx-car tagged-stx))] 313 [#:walk tagged-stx 314 (case (syntax-e (stx-car tagged-stx)) 315 ((#%app) 'tag-app) 316 ((#%datum) 'tag-datum) 317 ((#%top) 'tag-top) 318 (else 319 (error 'reductions "unknown tagged syntax: ~s" tagged-stx)))] 320 [Expr ?form next])] 321 322 ;; expand/compile-time-evals 323 324 [(Wrap ecte (e1 e2 locals first second locals2)) 325 (R [#:pattern ?form] 326 [#:pass1] 327 [LocalActions ?form locals] 328 [Expr ?form first] 329 [#:pass2] 330 [Expr ?form second] 331 [LocalActions ?form locals2])] 332 333 ;; Lifts 334 335 [(Wrap lift-deriv (e1 e2 first lifted-stx second)) 336 (R [#:pattern ?form] 337 ;; lifted-stx has form (begin lift-n ... lift-1 orig-expr) 338 [#:let avail (cdr (reverse (stx->list (stx-cdr lifted-stx))))] 339 [#:parameterize ((available-lift-stxs avail) 340 (visible-lift-stxs null)) 341 [#:pass1] 342 [Expr ?form first] 343 [#:do (when (pair? (available-lift-stxs)) 344 (lift-error 'lift-deriv "available lifts left over"))] 345 [#:with-visible-form 346 ;; If no lifts visible, then don't show begin-wrapping 347 [#:when (pair? (visible-lift-stxs)) 348 [#:walk (reform-begin-lifts lifted-stx 349 (visible-lift-stxs) 350 #'?form) 351 'capture-lifts]]] 352 [#:pass2] 353 [#:set-syntax lifted-stx] 354 [Expr ?form second]])] 355 356 [(Wrap lift/let-deriv (e1 e2 first lifted-stx second)) 357 (R [#:pattern ?form] 358 ;; lifted-stx has form 359 ;; (let-values ((last-v last-lifted)) 360 ;; ... 361 ;; (let-values ((first-v first-lifted)) orig-expr)) 362 [#:let avail lifted-stx] 363 [#:parameterize ((available-lift-stxs avail) 364 (visible-lift-stxs null)) 365 [#:pass1] 366 [Expr ?form first] 367 [#:let visible-lifts (visible-lift-stxs)] 368 [#:with-visible-form 369 [#:left-foot] 370 [#:set-syntax (reform-let-lifts lifted-stx visible-lifts #'?form)] 371 [#:step 'capture-lifts]] 372 [#:pass2] 373 [#:set-syntax lifted-stx] 374 [Expr ?form second]])] 375 376 ;; Skipped 377 [#f 378 (R)])) 379 380 ;; Expr/PhaseUp : Deriv -> RST 381 (define (Expr/PhaseUp d) 382 (R [#:parameterize ((phase (add1 (phase)))) 383 => (Expr* d)])) 384 385 ;; case-lambda-clauses-reductions : 386 ;; (list-of (W (list ?exn rename (W BDeriv)))) stxs -> RST 387 (define (CaseLambdaClauses clauses) 388 (match/count clauses 389 ['() 390 (R)] 391 [(cons (Wrap clc (?1 rename body)) rest) 392 (R [! ?1] 393 [#:pattern ((?formals . ?body) . ?rest)] 394 [#:rename (?formals . ?body) rename 'rename-case-lambda] 395 [#:binders #'?formals] 396 [Block ?body body] 397 [CaseLambdaClauses ?rest rest])])) 398 399 (define (PrepareEnv prep) 400 (LocalActions prep)) 401 402 ;; local-actions-reductions 403 (define (LocalActions locals) 404 (match locals 405 ['() 406 (R)] 407 [(cons local rest) 408 (R [#:pattern ?form] 409 [#:parameterize ((macro-policy 410 ;; If macro with local-expand is transparent, 411 ;; then all local-expansions must be transparent. 412 (if (visibility) (lambda _ #t) (macro-policy)))) 413 [#:new-local-context 414 [#:pattern ?form] 415 [LocalAction ?form local]]] 416 [LocalActions ?form rest])])) 417 418 (define (LocalAction local) 419 (match/count local 420 [(struct local-exn (exn)) 421 (R [! exn])] 422 423 [(struct local-expansion (e1 e2 for-stx? me1 inner #f me2 opaque)) 424 (R [#:parameterize ((phase (if for-stx? (add1 (phase)) (phase)))) 425 [#:set-syntax e1] 426 [#:pattern ?form] 427 [#:rename/mark ?form e1 me1] 428 [Expr ?form inner] 429 [#:rename/mark ?form me2 e2] 430 [#:do (when opaque 431 (hash-set! opaque-table (syntax-e opaque) e2))]])] 432 433 [(struct local-expansion (e1 e2 for-stx? me1 inner lifted me2 opaque)) 434 (R [#:let avail 435 (if for-stx? 436 lifted 437 (cdr (reverse (stx->list (stx-cdr lifted)))))] 438 [#:let recombine 439 (lambda (lifts form) 440 (if for-stx? 441 (reform-let-lifts lifted lifts form) 442 (reform-begin-lifts lifted lifts form)))] 443 [#:parameterize ((phase (if for-stx? (add1 (phase)) (phase))) 444 (available-lift-stxs avail) 445 (visible-lift-stxs null)) 446 [#:set-syntax e1] 447 [#:pattern ?form] 448 [#:rename/unmark ?form e1 me1] 449 [#:pass1] 450 [Expr ?form inner] 451 [#:let visible-lifts (visible-lift-stxs)] 452 [#:with-visible-form 453 [#:left-foot] 454 [#:set-syntax (recombine visible-lifts #'?form)] 455 [#:step 'splice-lifts visible-lifts]] 456 [#:pass2] 457 [#:set-syntax lifted] 458 [#:rename/mark ?form me2 e2] 459 [#:do (when opaque 460 (hash-set! opaque-table (syntax-e opaque) e2))]])] 461 462 [(struct local-lift (expr ids)) 463 ;; FIXME: add action 464 (R [#:do (take-lift!)] 465 [#:binders ids] 466 [#:reductions 467 (list 468 (walk/talk 'local-lift 469 (list "The macro lifted an expression" 470 "" 471 "Expression:" 472 expr 473 "Identifiers:" 474 (datum->syntax #f ids))))])] 475 476 [(struct local-lift-end (decl)) 477 ;; (walk/mono decl 'module-lift) 478 (R)] 479 [(struct local-lift-require (req expr mexpr)) 480 ;; lift require 481 (R [#:set-syntax expr] 482 [#:pattern ?form] 483 [#:rename/mark ?form expr mexpr])] 484 [(struct local-lift-provide (prov)) 485 ;; lift provide 486 (R)] 487 [(struct local-bind (names ?1 renames bindrhs)) 488 [R [! ?1] 489 ;; FIXME: use renames 490 [#:binders names] 491 [#:when bindrhs => (BindSyntaxes bindrhs)]]] 492 [(struct track-origin (before after)) 493 (R) 494 #| 495 ;; Do nothing for now... need to account for marks also. 496 [R [#:set-syntax before] 497 [#:pattern ?form] 498 [#:rename ?form after 'track-origin]] 499 |#] 500 [(struct local-value (name ?1 resolves bound? binding)) 501 [R [! ?1] 502 ;; FIXME: notify if binding != current (identifier-binding name)??? 503 ;; [#:learn (list name)] 504 ;; Add remark step? 505 ]] 506 [(struct local-remark (contents)) 507 (R [#:reductions (list (walk/talk 'remark contents))])] 508 [(struct local-mess (events)) 509 ;; FIXME: While it is not generally possible to parse tokens as one or more 510 ;; interrupted derivations (possibly interleaved with successful derivs), 511 ;; it should be possible to recover *some* information and display it. 512 (R [#:reductions 513 (let ([texts 514 (list (~a "Some expansion history has been lost due to a jump " 515 "within expansion.") 516 (~a "For example, a macro may have caught an " 517 "exception coming from within a call to `local-expand'."))]) 518 (list (walk/talk 'remark texts)))])] 519 [#f 520 (R)])) 521 522 (define (Submodules subs) 523 (match subs 524 ['() 525 (R)] 526 [(cons sub rest) 527 (R [#:pattern ?form] 528 [#:new-local-context 529 [#:pattern ?form] 530 [#:set-syntax (wderiv-e1 sub)] 531 [Expr ?form sub]] 532 [Submodules ?form rest])])) 533 534 ;; List : ListDerivation -> RST 535 (define (List ld) 536 (match ld 537 [(Wrap lderiv (es1 es2 ?1 derivs)) 538 (R [! ?1] 539 [#:pattern (?form ...)] 540 [Expr (?form ...) derivs])] 541 [#f 542 (R)])) 543 544 ;; Block : BlockDerivation -> RST 545 (define (Block bd) 546 (match/count bd 547 [(Wrap bderiv (es1 es2 pass1 trans pass2)) 548 (R [#:pattern ?block] 549 [#:pass1] 550 [BlockPass ?block pass1] 551 [#:pass2] 552 [#:if (eq? trans 'letrec) 553 (;; FIXME: foci (difficult because of renaming?) 554 [#:walk (list (wderiv-e1 pass2)) 'block->letrec] 555 [#:pattern (?expr)] 556 [Expr ?expr pass2]) 557 ([#:rename ?block (wlderiv-es1 pass2)] 558 [#:set-syntax (wlderiv-es1 pass2)] 559 [List ?block pass2])])] 560 ;; Alternatively, allow lists, since `let`, etc., bodies 561 ;; (generated form an internal definition context) are 562 ;; processed as a list. 563 [(Wrap lderiv (es1 es2 ?1 derivs)) 564 (R [! ?1] 565 [#:pattern (?form ...)] 566 [Expr (?form ...) derivs])] 567 [#f 568 (R)])) 569 570 ;; BlockPass : (list-of BRule) -> RST 571 (define (BlockPass brules) 572 (match/count brules 573 ['() 574 (R)] 575 [(cons (Wrap b:error (exn)) rest) 576 (R [! exn])] 577 [(cons (Wrap b:splice (renames head ?1 tail ?2)) rest) 578 (R [#:pattern (?first . ?rest)] 579 [#:rename/no-step ?first (car renames) (cdr renames)] 580 [#:pass1] 581 [Expr ?first head] 582 [! ?1] 583 [#:pass2] 584 [#:let begin-form #'?first] 585 [#:let rest-forms #'?rest] 586 [#:pattern ?forms] 587 [#:left-foot (list begin-form)] 588 [#:set-syntax (append (stx->list (stx-cdr begin-form)) rest-forms)] 589 [#:step 'splice-block (stx->list (stx-cdr begin-form))] 590 [#:rename ?forms tail] 591 [! ?2] 592 [#:pattern ?forms] 593 [BlockPass ?forms rest])] 594 595 ;; FIXME: are these pass1/2 necessary? 596 597 [(cons (Wrap b:defvals (renames head ?1 rename ?2)) rest) 598 (R [#:pattern (?first . ?rest)] 599 [#:rename/no-step ?first (car renames) (cdr renames)] 600 [#:pass1] 601 [Expr ?first head] 602 [! ?1] 603 [#:pattern ((?define-values ?vars . ?body) . ?rest)] 604 [#:rename (?vars . ?body) rename] 605 [#:binders #'?vars] 606 [! ?2] 607 [#:pass2] 608 [#:pattern (?first . ?rest)] 609 [BlockPass ?rest rest])] 610 [(cons (Wrap b:defstx (renames head ?1 rename ?2 prep bindrhs)) rest) 611 (R [#:pattern (?first . ?rest)] 612 [#:rename/no-step ?first (car renames) (cdr renames)] 613 [#:pass1] 614 [Expr ?first head] 615 [! ?1] 616 [#:pattern ((?define-syntaxes ?vars . ?body) . ?rest)] 617 [#:rename (?vars . ?body) rename] 618 [#:binders #'?vars] 619 [! ?2] 620 [#:pass2] 621 [#:pattern ?form] 622 [PrepareEnv ?form prep] 623 [#:pattern ((?define-syntaxes ?vars ?rhs) . ?rest)] 624 [BindSyntaxes ?rhs bindrhs] 625 [#:pattern (?first . ?rest)] 626 [BlockPass ?rest rest])] 627 [(cons (Wrap b:expr (renames head)) rest) 628 (R [#:pattern (?first . ?rest)] 629 [#:rename/no-step ?first (car renames) (cdr renames)] 630 [Expr ?first head] 631 [BlockPass ?rest rest])] 632 )) 633 634 ;; BindSyntaxes : BindSyntaxes -> RST 635 (define (BindSyntaxes bindrhs) 636 (match bindrhs 637 [(Wrap bind-syntaxes (rhs locals)) 638 (R [#:set-syntax (node-z1 rhs)] ;; set syntax; could be in local-bind 639 [#:pattern ?form] 640 [Expr/PhaseUp ?form rhs] 641 [LocalActions ?form locals])])) 642 643 (define (BeginForSyntax passes) 644 ;; Note: an lderiv doesn't necessarily cover all stxs, due to lifting. 645 (match/count passes 646 [(cons (? lderiv? lderiv) '()) 647 (R [#:pattern ?forms] 648 [List ?forms lderiv])] 649 [(cons (Wrap bfs:lift (lderiv stxs)) rest) 650 (R [#:pattern LDERIV] 651 [#:parameterize ((available-lift-stxs (reverse stxs)) 652 (visible-lift-stxs null)) 653 [#:pass1] 654 [List LDERIV lderiv] 655 [#:do (when (pair? (available-lift-stxs)) 656 (lift-error 'bfs:lift "available lifts left over"))] 657 [#:let visible-lifts (visible-lift-stxs)] 658 [#:pattern ?forms] 659 [#:pass2] 660 [#:let old-forms #'?forms] 661 [#:left-foot null] 662 [#:set-syntax (append visible-lifts old-forms)] 663 [#:step 'splice-lifts visible-lifts] 664 [#:set-syntax (append stxs old-forms)] 665 [BeginForSyntax ?forms rest]])])) 666 667 (define (ModuleBegin/Phase body) 668 (match/count body 669 [(Wrap module-begin/phase (pass1 pass2 pass3)) 670 (R [#:pass1] 671 [#:pattern ?forms] 672 [ModulePass ?forms pass1] 673 [#:pass2] 674 [#:do (DEBUG (printf "** module begin pass 2\n"))] 675 [ModulePass ?forms pass2] 676 ;; ignore pass3 for now: only provides 677 [#:new-local-context 678 [#:pattern ?form] 679 [LocalActions ?form (map expr->local-action (or pass3 null))]])])) 680 681 ;; ModulePass : (list-of MBRule) -> RST 682 (define (ModulePass mbrules) 683 (match/count mbrules 684 ['() 685 (R)] 686 [(cons (Wrap mod:prim (head rename prim)) rest) 687 (R [#:pattern (?firstP . ?rest)] 688 [Expr ?firstP head] 689 [#:do (DEBUG (printf "** after head\n"))] 690 [#:rename ?firstP rename] 691 [#:do (DEBUG (printf "** after rename\n"))] 692 [#:when prim 693 [Expr ?firstP prim]] 694 [#:do (DEBUG (printf "** after prim\n"))] 695 [ModulePass ?rest rest])] 696 [(cons (Wrap mod:splice (head rename ?1 tail)) rest) 697 (R [#:pattern (?firstB . ?rest)] 698 [#:pass1] 699 [Expr ?firstB head] 700 [#:pass2] 701 [#:rename ?firstB rename] 702 [! ?1] 703 [#:let begin-form #'?firstB] 704 [#:let rest-forms #'?rest] 705 [#:left-foot (list #'?firstB)] 706 [#:pattern ?forms] 707 [#:set-syntax (append (stx->list (stx-cdr begin-form)) rest-forms)] 708 [#:step 'splice-module (stx->list (stx-cdr begin-form))] 709 [#:rename ?forms tail] 710 [ModulePass ?forms rest])] 711 [(cons (Wrap mod:lift (head locals renames stxs)) rest) 712 (R [#:pattern (?firstL . ?rest)] 713 ;; renames has form (head-e2 . ?rest) 714 ;; stxs has form (lifted ...), 715 ;; specifically (last-lifted ... first-lifted) 716 [#:parameterize ((available-lift-stxs (reverse stxs)) 717 (visible-lift-stxs null)) 718 [#:pass1] 719 [Expr ?firstL head] 720 [LocalActions ?firstL locals] 721 [#:do (when (pair? (available-lift-stxs)) 722 (lift-error 'mod:lift "available lifts left over"))] 723 [#:let visible-lifts (visible-lift-stxs)] 724 [#:pattern ?forms] 725 [#:pass2] 726 [#:when renames 727 [#:rename ?forms renames]] 728 [#:let old-forms #'?forms] 729 [#:left-foot null] 730 [#:set-syntax (append visible-lifts old-forms)] 731 [#:step 'splice-lifts visible-lifts] 732 [#:set-syntax (append stxs old-forms)] 733 [ModulePass ?forms rest]])] 734 [(cons (Wrap mod:lift-end (stxs)) rest) 735 ;; In pass2, stxs contains a mixture of terms and kind-tagged terms (pairs) 736 (let ([stxs (map (lambda (e) (if (pair? e) (car e) e)) stxs)]) 737 (R [#:pattern ?forms] 738 [#:when (pair? stxs) 739 [#:left-foot null] 740 [#:set-syntax (append stxs #'?forms)] 741 [#:step 'splice-module-lifts stxs]] 742 [ModulePass ?forms rest]))] 743 [(cons (Wrap mod:skip ()) rest) 744 (R [#:pattern (?firstS . ?rest)] 745 [ModulePass ?rest rest])] 746 [(cons (Wrap mod:cons (head locals)) rest) 747 (R [#:pattern (?firstC . ?rest)] 748 [Expr ?firstC head] 749 [LocalActions ?firstC locals] 750 [ModulePass ?rest rest])])) 751 752 ;; Lifts 753 754 (define (take-lift!) 755 (define avail (available-lift-stxs)) 756 (cond [(list? avail) 757 #| 758 ;; This check is wrong! (and thus disabled) 759 ;; If a syntax error occurs between the time a lift is "thrown" 760 ;; and when it is "caught", no lifts will be available to take. 761 ;; But that's not a bug, so don't complain. 762 (unless (pair? avail) 763 (lift-error 'local-lift "out of lifts (begin)!")) 764 |# 765 (when (pair? avail) 766 (let ([lift-stx (car avail)]) 767 (available-lift-stxs (cdr avail)) 768 (when (visibility) 769 (visible-lift-stxs 770 (cons lift-stx (visible-lift-stxs))))))] 771 [else 772 (syntax-case avail () 773 [(?let-values ?lift ?rest) 774 (eq? (syntax-e #'?let-values) 'let-values) 775 (begin (available-lift-stxs #'?rest) 776 (when (visibility) 777 (visible-lift-stxs 778 (cons (datum->syntax avail (list #'?let-values #'?lift) 779 avail avail) 780 (visible-lift-stxs)))))] 781 [_ 782 (lift-error 'local-lift "out of lifts (let)!")])])) 783 784 (define (reform-begin-lifts orig-lifted lifts body) 785 (define begin-kw (stx-car orig-lifted)) 786 (datum->syntax orig-lifted 787 `(,begin-kw ,@lifts ,body) 788 orig-lifted 789 orig-lifted)) 790 791 (define (reform-let-lifts orig-lifted lifts body) 792 (if (null? lifts) 793 body 794 (reform-let-lifts orig-lifted 795 (cdr lifts) 796 (with-syntax ([(?let-values ?lift) (car lifts)]) 797 (datum->syntax (car lifts) 798 `(,#'?let-values ,#'?lift ,body) 799 (car lifts) 800 (car lifts)))))) 801 802 ;; lift-error 803 (define (lift-error sym . args) 804 (apply eprintf args) 805 (newline (current-error-port)) 806 (when #f 807 (apply error sym args))) 808 809 (define (expr->local-action d) 810 (match d 811 [(Wrap deriv (e1 e2)) 812 (make local-expansion e1 e2 813 #f e1 d #f e2 #f)])) 814 815 ;; opaque-table 816 ;; Weakly remembers assoc between opaque values and 817 ;; actual syntax, so that actual can be substituted in 818 ;; for destructuring. 819 ;; FIXME: perhaps add event for opaque-stx unwrapping? 820 (define opaque-table (make-weak-hasheq))