deriv-parser.rkt - www - Unnamed repository; edit this file 'description' to name the repository.

deriv-parser.rkt (19752B)
      1 #lang racket/base
      2 (require (for-syntax racket/base)
      3          syntax/stx
      4          "yacc-ext.rkt"
      5          "yacc-interrupted.rkt"
      6          "deriv.rkt"
      7          "deriv-util.rkt"
      8          "deriv-tokens.rkt")
      9 (provide parse-derivation)
     10 
     11 (define (deriv-error ok? name value start end)
     12   (if ok?
     13       (error 'derivation-parser
     14              "error on token #~a: <~s, ~s>"
     15              start name value)
     16       (error 'derivation-parser "bad token #~a" start)))
     17 
     18 ;; PARSER
     19 
     20 (define-production-splitter production/I values values)
     21 
     22 (define-syntax (productions/I stx)
     23   (syntax-case stx ()
     24     [(productions/I def ...)
     25      #'(begin (production/I def) ...)]))
     26 
     27 (define parse-derivation
     28   (parser
     29    (options (start Expansion)
     30             (src-pos)
     31             (tokens basic-empty-tokens basic-tokens prim-tokens renames-tokens)
     32             (end EOF)
     33             #| (debug "/tmp/DEBUG-PARSER.txt") |#
     34             (error deriv-error))
     35 
     36    ;; tokens
     37    (skipped-token-values
     38     visit resolve next next-group return
     39     enter-macro macro-pre-transform macro-post-transform exit-macro 
     40     enter-prim exit-prim
     41     enter-block block->list block->letrec splice
     42     enter-list exit-list
     43     enter-check exit-check
     44     local-post exit-local exit-local/expr
     45     local-bind enter-bind exit-bind exit-local-bind
     46     local-value-result local-value-binding
     47     phase-up module-body
     48     renames-lambda
     49     renames-case-lambda
     50     renames-let
     51     renames-letrec-syntaxes
     52     renames-block
     53     rename-one
     54     rename-list
     55     tag
     56     IMPOSSIBLE
     57     start
     58     top-non-begin
     59     prepare-env)
     60 
     61     ;; Entry point
     62    (productions
     63     (Expansion
     64      [(start EE/Lifts) $2]
     65      [(start EE/Lifts/Interrupted) $2]
     66      [(start ExpandCTE) $2]
     67      [(start ExpandCTE/Interrupted) $2]))
     68 
     69    (productions/I
     70 
     71     (ExpandCTE
     72      ;; The first 'Eval' is there for---I believe---lazy phase 1 initialization.
     73      [(visit start (? Eval) (? CheckImmediateMacro/Lifts)
     74              top-non-begin start (? EE) (? Eval) return)
     75       (make ecte $1 $9 $3 $4 $7 $8)]
     76      [(visit start Eval CheckImmediateMacro/Lifts
     77              top-begin (? NextExpandCTEs) return)
     78       (begin
     79         (unless (list? $6)
     80           (error "NextExpandCTEs returned non-list ~s" $6))
     81         (make ecte $1 $7 $3 $4
     82               (make p:begin $5 $7 (list (stx-car $5)) #f
     83                     (make lderiv (cdr (stx->list $5))
     84                           (and $7 (cdr (stx->list $7)))
     85                           #f
     86                           $6))
     87               null))])
     88 
     89     (CheckImmediateMacro/Lifts
     90      [((? CheckImmediateMacro))
     91       $1]
     92      [(CheckImmediateMacro lift-loop)
     93       (let ([e1 (wderiv-e1 $1)]
     94             [e2 $2])
     95         (make lift-deriv e1 e2 $1 $2 (make p:stop $2 $2 null #f)))])
     96 
     97     (NextExpandCTEs
     98      (#:skipped null)
     99      [() null]
    100      [(next (? ExpandCTE) (? NextExpandCTEs)) (cons $2 $3)])
    101 
    102     ;; Expand with possible lifting
    103     (EE/Lifts
    104      [((? EE)) $1]
    105      [(EE lift-loop (? EE/Lifts))
    106       (let ([e1 (wderiv-e1 $1)]
    107             [e2 (wderiv-e2 $3)])
    108         (make lift-deriv e1 e2 $1 $2 $3))])
    109 
    110     ;; Expand, convert lifts to let (rhs of define-syntaxes, mostly)
    111     (EE/LetLifts
    112      [((? EE)) $1]
    113      [(EE lift/let-loop (? EE/LetLifts))
    114       (let ([initial (wderiv-e1 $1)]
    115             [final (wderiv-e2 $3)])
    116         (make lift/let-deriv initial final $1 $2 $3))])
    117 
    118     ;; Evaluation
    119     ;; Answer = (listof LocalAction)
    120     (Eval
    121      (#:skipped null)
    122      [((? LocalActions)) $1])
    123 
    124     ;; Prepare env for compilation
    125     (PrepareEnv
    126      [(prepare-env (? Eval)) $2])
    127 
    128     ;; Expansion of an expression to primitive form
    129     (CheckImmediateMacro
    130      [(enter-check (? CheckImmediateMacro/Inner) exit-check)
    131       ($2 $1 $3)])
    132     (CheckImmediateMacro/Inner
    133      (#:args le1 e2)
    134      [(!)
    135       (make p:stop le1 e2 null $1)]
    136      [(visit Resolves (? MacroStep) return (? CheckImmediateMacro/Inner))
    137       ($3 $1 $2 ($5 $4 e2))]
    138      [(visit Resolves tag (? MacroStep) return (? CheckImmediateMacro/Inner))
    139       (let ([mnode ($4 $3 $2 ($6 $5 e2))])
    140         (make tagrule $1 (wderiv-e2 mnode) $3 mnode))])
    141 
    142     ;; Expansion of multiple expressions, next-separated
    143     (NextEEs
    144      (#:skipped null)
    145      [() null]
    146      [(next (? EE) (? NextEEs)) (cons $2 $3)])
    147 
    148     ;; EE
    149 
    150     ;; Expand expression (term)
    151     (EE
    152      [(visit Resolves (? EE/k))
    153       ($3 $1 $2)]
    154      [(visit Resolves tag (? EE/k))
    155       (let ([next ($4 $3 $2)])
    156         (make tagrule $1 (wderiv-e2 next) $3 next))]
    157      [(visit opaque)
    158       (make p:stop $1 $2 null #f)])
    159 
    160     (EE/k
    161      (#:args e1 rs)
    162      [(!!)
    163       (make p:unknown e1 #f rs $1)]
    164      [(variable return)
    165       (make p:variable e1 $2 rs #f)]
    166      [(enter-prim (? Prim) exit-prim return)
    167       (begin
    168         (unless (eq? $3 $4)
    169           (eprintf "warning: exit-prim and return differ:\n~s\n~s\n" $3 $4))
    170         ($2 $1 $3 rs))]
    171      [((? MacroStep) (? EE))
    172       ($1 e1 rs $2)])
    173 
    174     (MacroStep
    175      (#:args e1 rs next)
    176      [(enter-macro ! macro-pre-transform (? LocalActions)
    177                    macro-post-transform ! exit-macro)
    178       (let ([e2 (and next (wderiv-e2 next))])
    179         (make mrule e1 e2 rs $2
    180               $3 $4 (and $5 (car $5)) $6 $7 next))])
    181 
    182     ;; Keyword resolution
    183     (Resolves
    184      [() null]
    185      [(resolve Resolves) (cons $1 $2)])
    186 
    187     ;; Local actions taken by macro
    188     ;; LocalAction Answer = (list-of LocalAction)
    189     (LocalActions
    190      (#:skipped null)
    191      [() null]
    192      [((? LocalAction) (? LocalActions)) (cons $1 $2)])
    193 
    194     (LocalAction
    195      [(!!) (make local-exn $1)]
    196      [(enter-local OptPhaseUp
    197        local-pre (? LocalExpand/Inner) OptLifted local-post
    198        OptOpaqueExpr exit-local)
    199       (make local-expansion $1 $8 $2 $3 $4 $5 $6 $7)]
    200      [(lift)
    201       (make local-lift (cdr $1) (car $1))]
    202      [(lift-statement)
    203       (make local-lift-end $1)]
    204      [(lift-require)
    205       (make local-lift-require (car $1) (cadr $1) (cddr $1))]
    206      [(lift-provide)
    207       (make local-lift-provide $1)]
    208      [(local-bind ! rename-list exit-local-bind)
    209       (make local-bind $1 $2 $3 #f)]
    210      [(local-bind rename-list (? BindSyntaxes) exit-local-bind)
    211       (make local-bind $1 #f $2 $3)]
    212      [(track-origin)
    213       (make track-origin (car $1) (cdr $1))]
    214      [(local-value ! Resolves local-value-result local-value-binding)
    215       (make local-value $1 $2 $3 $4 $5)]
    216      [(local-remark)
    217       (make local-remark $1)]
    218      [(local-artificial-step)
    219       (let ([ids (list-ref $1 0)]
    220             [before (list-ref $1 1)]
    221             [mbefore (list-ref $1 2)]
    222             [mafter (list-ref $1 3)]
    223             [after (list-ref $1 4)])
    224         (make local-expansion
    225           before after #f mbefore
    226           (make mrule mbefore mafter ids #f
    227                 before null after #f mafter
    228                 (make p:stop mafter mafter null #f))
    229           #f after #f))]
    230      [(local-mess)
    231       ;; Represents subsequence of event stream incoherent due to
    232       ;; jump (eg, macro catches exn raised from within local-expand).
    233       (make local-mess $1)]
    234      ;; -- Not really local actions, but can occur during evaluation
    235      ;; called 'expand' (not 'local-expand') within transformer
    236      [(start (? EE)) #f]
    237      [(start (? CheckImmediateMacro)) #f])
    238 
    239     (LocalExpand/Inner
    240      [(start (? EE)) $2]
    241      [((? CheckImmediateMacro)) $1])
    242 
    243     (OptLifted
    244      [(lift-loop) $1]
    245      [() #f])
    246     (OptOpaqueExpr
    247      [(opaque) $1]
    248      [() #f])
    249     (OptPhaseUp
    250      [(phase-up) #t]
    251      [() #f])
    252 
    253     (Prim
    254      (#:args e1 e2 rs)
    255      [((? PrimModule)) ($1 e1 e2 rs)]
    256      [((? Prim#%ModuleBegin)) ($1 e1 e2 rs)]
    257      [((? PrimDefineSyntaxes)) ($1 e1 e2 rs)]
    258      [((? PrimDefineValues)) ($1 e1 e2 rs)]
    259      [((? PrimExpression)) ($1 e1 e2 rs)]
    260      [((? Prim#%App)) ($1 e1 e2 rs)]
    261      [((? Prim#%Datum)) ($1 e1 e2 rs)]
    262      [((? Prim#%Top)) ($1 e1 e2 rs)]
    263      [((? PrimIf)) ($1 e1 e2 rs)]
    264      [((? PrimWCM)) ($1 e1 e2 rs)]
    265      [((? PrimSet)) ($1 e1 e2 rs)]
    266      [((? PrimBegin)) ($1 e1 e2 rs)]
    267      [((? PrimBegin0)) ($1 e1 e2 rs)]
    268      [((? PrimLambda)) ($1 e1 e2 rs)]
    269      [((? PrimCaseLambda)) ($1 e1 e2 rs)]
    270      [((? PrimLetValues)) ($1 e1 e2 rs)]
    271      [((? PrimLet*Values)) ($1 e1 e2 rs)]
    272      [((? PrimLetrecValues)) ($1 e1 e2 rs)]
    273      [((? PrimLetrecSyntaxes+Values)) ($1 e1 e2 rs)]
    274      [((? PrimSTOP)) ($1 e1 e2 rs)]
    275      [((? PrimQuote)) ($1 e1 e2 rs)]
    276      [((? PrimQuoteSyntax)) ($1 e1 e2 rs)]
    277      [((? PrimRequire)) ($1 e1 e2 rs)]
    278      [((? PrimProvide)) ($1 e1 e2 rs)]
    279      [((? PrimVarRef)) ($1 e1 e2 rs)]
    280      [((? PrimStratifiedBody)) ($1 e1 e2 rs)]
    281      [((? PrimBeginForSyntax)) ($1 e1 e2 rs)])
    282 
    283     (PrimModule
    284      (#:args e1 e2 rs)
    285      [(prim-module ! (? PrepareEnv) OptTag rename-one
    286                    (? OptCheckImmediateMacro) OptTag !
    287                    (? EE) rename-one)
    288       (make p:module e1 e2 rs $2 $3 $4 $5 $6 $7 $8 $9 $10)])
    289     (OptTag
    290      [() #f]
    291      [(tag) $1])
    292     (OptCheckImmediateMacro
    293      [() #f]
    294      [((? CheckImmediateMacro)) $1])
    295 
    296     ;; FIXME: workaround for problem in expander instrumentation:
    297     ;;   observer not propagated correctly to expand_all_provides
    298     ;;   so local actions that should be within prim-provide's EE 
    299     ;;   instead appear directly here
    300     (Prim#%ModuleBegin
    301      (#:args e1 e2 rs)
    302      [(prim-#%module-begin ! rename-one (? ModuleBegin/Phase) (? Eval) next (? ExpandSubmodules))
    303       (make p:#%module-begin e1 e2 rs $2 $3 $4
    304             (for/or ([la (in-list $5)])
    305               (and (local-exn? la) (local-exn-exn la)))
    306             $7)])
    307     #|
    308     ;; restore this version when expander fixed
    309     (Prim#%ModuleBegin-REAL
    310      (#:args e1 e2 rs)
    311      [(prim-#%module-begin ! rename-one (? ModuleBegin/Phase) ! (? ExpandSubmodules))
    312       (make p:#%module-begin e1 e2 rs $2 $3 $4 $5)])
    313     |#
    314     (ExpandSubmodules
    315      (#:skipped null)
    316      [(enter-prim (? PrimModule) exit-prim (? ExpandSubmodules))
    317       (cons ($2 $1 $3 null) $4)]
    318      [() null])
    319 
    320     (ModuleBegin/Phase
    321      [((? ModulePass1) next-group (? ModulePass2) next-group (? ModulePass3))
    322       (make module-begin/phase $1 $3 $5)])
    323 
    324     (ModulePass1
    325      (#:skipped null)
    326      [() null]
    327      [(next (? ModulePass1-Part) (? ModulePass1))
    328       (cons $2 $3)]
    329      [(module-lift-end-loop (? ModulePass1))
    330       (cons (make mod:lift-end $1) $2)])
    331 
    332     (ModulePass1-Part
    333      [((? EE) rename-one (? ModulePass1/Prim))
    334       (make mod:prim $1 $2 ($3 $2))]
    335      [(EE rename-one ! splice)
    336       (make mod:splice $1 $2 $3 $4)]
    337      [(EE rename-list module-lift-loop)
    338       (make mod:lift $1 null $2 $3)])
    339 
    340     (ModulePass1/Prim
    341      (#:args e1)
    342      [(enter-prim prim-define-values ! exit-prim)
    343       (make p:define-values $1 $4 null $3 #f)]
    344      [(enter-prim prim-define-syntaxes ! (? PrepareEnv)
    345                   phase-up (? EE/LetLifts) (? Eval) exit-prim)
    346       (make p:define-syntaxes $1 $8 null $3 $4 $6 $7)]
    347      [(enter-prim prim-begin-for-syntax ! (? PrepareEnv)
    348                   phase-up (? ModuleBegin/Phase) (? Eval) exit-prim)
    349       (make p:begin-for-syntax $1 $7 null $3 $4 $6 $7)]
    350      [(enter-prim prim-require (? Eval) exit-prim)
    351       (make p:require $1 $4 null #f $3)]
    352      [(enter-prim prim-submodule ! (? ExpandSubmodules #|one|#) exit-prim)
    353       (make p:submodule $1 $5 null $3 (car $4))]
    354      [(enter-prim prim-submodule* ! exit-prim)
    355       (make p:submodule* $1 $4 null $3)]
    356      [()
    357       (make p:stop e1 e1 null #f)])
    358 
    359     (ModulePass2
    360      (#:skipped null)
    361      [() null]
    362      [(next (? ModulePass2-Part) (? ModulePass2))
    363       (cons $2 $3)]
    364      [(module-lift-end-loop (? ModulePass2))
    365       (cons (make mod:lift-end $1) $2)])
    366 
    367     (ModulePass2-Part
    368      ;; not normal; already handled
    369      [()
    370       (make mod:skip)]
    371      ;; normal: expand completely
    372      [((? EE) (? Eval))
    373       ;; after expansion, may compile => may eval letstx rhss again!
    374       ;; need to include those evals too (for errors, etc)
    375       (make mod:cons $1 $2)]
    376      ;; catch lifts
    377      [(EE Eval module-lift-loop)
    378       ;; same as above: after expansion, may compile => may eval
    379       (make mod:lift $1 $2 #f $3)])
    380 
    381     (ModulePass3
    382      (#:skipped null)
    383      [() null]
    384      [((? ModulePass3-Part) (? ModulePass3))
    385       (cons $1 $2)])
    386 
    387     (ModulePass3-Part
    388      [(enter-prim prim-provide (? ModuleProvide/Inner) ! exit-prim)
    389       (make p:provide $1 $5 null #f $3 $4)])
    390 
    391     (ModuleProvide/Inner
    392      (#:skipped null)
    393      [() null]
    394      [((? EE) (? ModuleProvide/Inner))
    395       (cons $1 $2)])
    396 
    397     ;; Definitions
    398     (PrimDefineSyntaxes
    399      (#:args e1 e2 rs)
    400      [(prim-define-syntaxes ! (? PrepareEnv) (? EE/LetLifts) (? Eval))
    401       (make p:define-syntaxes e1 e2 rs $2 $3 $4 $5)])
    402 
    403     (PrimDefineValues
    404      (#:args e1 e2 rs)
    405      [(prim-define-values ! (? EE))
    406       (make p:define-values e1 e2 rs $2 $3)])
    407 
    408     ;; Simple expressions
    409     (PrimExpression
    410      (#:args e1 e2 rs)
    411      [(prim-expression ! (? EE))
    412       (make p:#%expression e1 e2 rs $2 $3 #f)]
    413      [(prim-expression EE tag)
    414       (make p:#%expression e1 e2 rs #f $2 $3)])
    415 
    416     (PrimIf
    417      (#:args e1 e2 rs)
    418      [(prim-if ! (? EE) next (? EE) next (? EE))
    419       (make p:if e1 e2 rs $2 $3 $5 $7)])
    420 
    421     (PrimWCM 
    422      (#:args e1 e2 rs)
    423      [(prim-wcm ! (? EE) next (? EE) next (? EE))
    424       (make p:wcm e1 e2 rs $2 $3 $5 $7)])
    425 
    426     ;; Sequence-containing expressions
    427     (PrimBegin
    428      (#:args e1 e2 rs)
    429      [(prim-begin ! (? EL))
    430       (make p:begin e1 e2 rs $2 $3)])
    431 
    432     (PrimBegin0
    433      (#:args e1 e2 rs)
    434      [(prim-begin0 ! next (? EE) next (? EL))
    435       (make p:begin0 e1 e2 rs $2 $4 $6)])
    436 
    437     (Prim#%App
    438      (#:args e1 e2 rs)
    439      [(prim-#%app !)
    440       (make p:#%app e1 e2 rs $2 #f)]
    441      [(prim-#%app (? EL))
    442       (make p:#%app e1 e2 rs #f $2)])
    443 
    444     ;; Binding expressions
    445     (PrimLambda
    446      (#:args e1 e2 rs)
    447      [(prim-lambda ! renames-lambda (? EB))
    448       (make p:lambda e1 e2 rs $2 $3 $4)])
    449 
    450     (PrimCaseLambda
    451      (#:args e1 e2 rs)
    452      [(prim-case-lambda ! (? NextCaseLambdaClauses))
    453       (make p:case-lambda e1 e2 rs $2 $3)])
    454 
    455     (NextCaseLambdaClauses
    456      (#:skipped null)
    457      [(next (? CaseLambdaClause) (? NextCaseLambdaClauses))
    458       (cons $2 $3)]
    459      [() null])
    460 
    461     (CaseLambdaClause
    462      [(! renames-case-lambda (? EB))
    463       (make clc $1 $2 $3)])
    464 
    465     (PrimLetValues
    466      (#:args e1 e2 rs)
    467      [(prim-let-values ! renames-let (? NextEEs) next-group (? EB/EL))
    468       (make p:let-values e1 e2 rs $2 $3 $4 $6)])
    469 
    470     ;; There's no primitive `let*-values`, anymore
    471     (PrimLet*Values
    472      (#:args e1 e2 rs)
    473      ;; let*-values with bindings is "macro-like"
    474      [(prim-let*-values !!)
    475       (make mrule e1 e2 rs $2 #f null #f #f #f #f)]
    476      [(prim-let*-values (? EE))
    477       (let* ([next-e1 (wderiv-e1 $2)])
    478         (make mrule e1 e2 rs #f e1 null next-e1 #f next-e1 $2))]
    479      ;; No bindings... model as "let"
    480      [(prim-let*-values renames-let (? NextEEs) next-group (? EB))
    481       (make p:let-values e1 e2 rs #f $2 $3 $5)])
    482 
    483     (PrimLetrecValues
    484      (#:args e1 e2 rs)
    485      [(prim-letrec-values ! renames-let (? NextEEs) next-group (? EB/EL))
    486       (make p:letrec-values e1 e2 rs $2 $3 $4 $6)])
    487 
    488     (PrimLetrecSyntaxes+Values
    489      (#:args e1 e2 rs)
    490      [(prim-letrec-syntaxes+values ! renames-letrec-syntaxes
    491        (? PrepareEnv) (? NextBindSyntaxess) next-group (? EB/EL) OptTag)
    492       (make p:letrec-syntaxes+values e1 e2 rs $2 $3 $4 $5 #f null $7 $8)]
    493      [(prim-letrec-syntaxes+values renames-letrec-syntaxes 
    494        PrepareEnv NextBindSyntaxess next-group
    495        prim-letrec-values
    496        renames-let (? NextEEs) next-group (? EB/EL) OptTag)
    497       (make p:letrec-syntaxes+values e1 e2 rs #f $2 $3 $4 $7 $8 $10 $11)])
    498 
    499     ;; Atomic expressions
    500     (Prim#%Datum
    501      (#:args e1 e2 rs)
    502      [(prim-#%datum !) (make p:#%datum e1 e2 rs $2)])
    503 
    504     (Prim#%Top
    505      (#:args e1 e2 rs)
    506      [(prim-#%top !) (make p:#%top e1 e2 rs $2)])
    507 
    508     (PrimSTOP
    509      (#:args e1 e2 rs)
    510      [(prim-stop !) (make p:stop e1 e2 rs $2)])
    511 
    512     (PrimQuote
    513      (#:args e1 e2 rs)
    514      [(prim-quote !) (make p:quote e1 e2 rs $2)])
    515 
    516     (PrimQuoteSyntax
    517      (#:args e1 e2 rs)
    518      [(prim-quote-syntax !) (make p:quote-syntax e1 e2 rs $2)])
    519 
    520     (PrimRequire
    521      (#:args e1 e2 rs)
    522      [(prim-require (? Eval))
    523       (make p:require e1 e2 rs #f $2)])
    524 
    525     (PrimProvide 
    526      (#:args e1 e2 rs)
    527      [(prim-provide !) (make p:provide e1 e2 rs $2 null #f)])
    528 
    529     (PrimVarRef
    530      (#:args e1 e2 rs)
    531      [(prim-varref !) (make p:#%variable-reference e1 e2 rs $2)])
    532 
    533     (PrimStratifiedBody
    534      (#:args e1 e2 rs)
    535      [(prim-#%stratified-body ! (? EB)) (make p:#%stratified-body e1 e2 rs $2 $3)])
    536 
    537     (PrimBeginForSyntax
    538      (#:args e1 e2 rs)
    539      [(prim-begin-for-syntax ! (? PrepareEnv) (? BeginForSyntax*) (? Eval))
    540       (make p:begin-for-syntax e1 e2 rs $2 $3 $4 $5)])
    541     (BeginForSyntax*
    542      [((? EL))
    543       (list $1)]
    544      [(EL module-lift-loop (? BeginForSyntax*))
    545       (cons (make bfs:lift $1 $2) $3)])
    546 
    547     (PrimSet
    548      (#:args e1 e2 rs)
    549      ;; Unrolled to avoid shift/reduce
    550      [(prim-set! ! resolve Resolves ! next (? EE))
    551       (make p:set! e1 e2 rs $2 (cons $3 $4) $5 $7)]
    552      [(prim-set! Resolves (? MacroStep) (? EE))
    553       (make p:set!-macro e1 e2 rs #f ($3 e1 $2 $4))])
    554     
    555     ;; When an internal-definition context expands to `let`, `letrec`, etc.,
    556     ;; then the body is processed as a list (since it has already been
    557     ;; processed as a block)
    558     (EB/EL
    559      [((? EB)) $1]
    560      [((? EL)) $1])
    561 
    562     ;; Blocks
    563     ;; EB Answer = BlockDerivation
    564     (EB
    565      [(enter-block (? BlockPass1) block->list (? EL))
    566       (make bderiv $1 (and $4 (wlderiv-es2 $4))
    567             $2 'list $4)]
    568      [(enter-block BlockPass1 block->letrec (? EE))
    569       (make bderiv $1 (and $4 (list (wderiv-e2 $4)))
    570             $2 'letrec $4)])
    571 
    572     ;; BlockPass1 Answer = (list-of BRule)
    573     (BlockPass1
    574      [(renames-block (? BlockPass1*))
    575       (map (install-renames-block $1) $2)])
    576 
    577     ;; BlockPass1 Answer = (list-of BRule)
    578     (BlockPass1*
    579      (#:skipped null)
    580      [() null]
    581      [((? BRule) (? BlockPass1*))
    582       (cons $1 $2)])
    583 
    584     ;; BRule Answer = BRule
    585     (BRule
    586      [(next !!)
    587       (make b:error $2)]
    588      [(next (? CheckImmediateMacro))
    589       (make b:expr '... $2)]
    590      [(next CheckImmediateMacro prim-begin ! splice !)
    591       (make b:splice '... $2 $4 $5 $6)]
    592      [(next CheckImmediateMacro prim-define-values ! rename-one !)
    593       (make b:defvals '... $2 $4 $5 $6)]
    594      [(next CheckImmediateMacro
    595             prim-define-syntaxes ! rename-one ! (? PrepareEnv) (? BindSyntaxes))
    596       (make b:defstx '... $2 $4 $5 $6 $7 $8)])
    597 
    598     ;; BindSyntaxes Answer = Derivation
    599     (BindSyntaxes
    600      [(enter-bind (? EE/LetLifts) next (? Eval) exit-bind)
    601       (make bind-syntaxes $2 $4)])
    602 
    603     ;; NextBindSyntaxess Answer = (list-of Derivation)
    604     (NextBindSyntaxess
    605      (#:skipped null)
    606      [() null]
    607      [(next (? BindSyntaxes) (? NextBindSyntaxess)) (cons $2 $3)])
    608 
    609     ;; Lists
    610     ;; EL Answer = ListDerivation
    611     (EL
    612      (#:skipped #f)
    613      [(enter-list ! (? EL*) exit-list)
    614       ;; FIXME: Workaround for bug in events
    615       (if (null? $3)
    616           (make lderiv null null $2 $3)
    617           (make lderiv $1 $4 $2 $3))])
    618 
    619     ;; EL* Answer = (listof Derivation)
    620     (EL*
    621      (#:skipped null)
    622      [() null]
    623      [(next (? EE) (? EL*)) (cons $2 $3)])
    624 
    625     )))
    626 
    627 ;; Used to move a `renames` block that is provided once into each of
    628 ;; a list of brules, since the old expander provided the renames for
    629 ;; each brule
    630 (define ((install-renames-block renames) b)
    631   (cond
    632    [(b:expr? b)
    633     (struct-copy b:expr b [renames #:parent brule renames])]
    634    [(b:splice? b)
    635     (struct-copy b:splice b [renames #:parent brule renames])]
    636    [(b:defvals? b)
    637     (struct-copy b:defvals b [renames #:parent brule renames])]
    638    [(b:defstx? b)
    639     (struct-copy b:defstx b [renames #:parent brule renames])]
    640    [else (error 'internal "unrecognized brule: ~e" b)]))
	www Unnamed repository; edit this file 'description' to name the repository.
	Log \| Files \| Refs