mlton/front-end/mlb.grm

   1 (* Copyright (C) 2009 Matthew Fluet.
   2  * Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  * Copyright (C) 1997-2000 NEC Research Institute.
   5  *
   6  * MLton is released under a BSD-style license.
   7  * See the file MLton-LICENSE for details.
   8  *)
   9
  10 fun reg (left, right) = Region.make {left = left, right = right}
  11 fun error (reg, msg) = Control.error (reg, Layout.str msg, Layout.empty)
  12
  13 open Ast
  14
  15 type fctbinds = {lhs: Fctid.t, rhs: Fctid.t} list
  16 type sigbinds = {lhs: Sigid.t, rhs: Sigid.t} list
  17 type strbinds = {lhs: Strid.t, rhs: Strid.t} list
  18
  19 type basbinds = {name: Basid.t, def: Basexp.t} list
  20
  21   %%
  22 %term
  23       ID of string | COMMA | SEMICOLON | EOF
  24     | AND | BAS | BASIS | END | EQUALOP | FUNCTOR | IN | LET
  25     | LOCAL | OPEN | SIGNATURE | STRUCTURE
  26     | ANN | PRIM | FILE of string | STRING of string
  27
  28 %nonterm
  29          ann of string * Region.t
  30        | annPlus of (string * Region.t) list
  31        | annStar of (string * Region.t) list
  32        | basbinds of basbinds
  33        | basbinds' of Basexp.t * basbinds
  34        | basbinds'' of basbinds
  35        | basdec of Basdec.t
  36        | basdecnode of Basdec.node
  37        | basdecs of Basdec.t
  38        | basdecsnode of Basdec.node
  39        | basexp of Basexp.t
  40        | basexpnode of Basexp.node
  41        | basid of Basid.t
  42        | basids of Basid.t list
  43        | fctbinds of fctbinds
  44        | fctbinds' of Fctid.t * fctbinds
  45        | fctbinds'' of fctbinds
  46        | fctid of Fctid.t
  47        | id of Symbol.t * Region.t
  48        | mlb of Basdec.t
  49        | sigbinds of sigbinds
  50        | sigbinds' of Sigid.t * sigbinds
  51        | sigbinds'' of sigbinds
  52        | sigid of Sigid.t
  53        | strbinds of strbinds
  54        | strbinds' of Strid.t * strbinds
  55        | strbinds'' of strbinds
  56        | strid of Strid.t
  57
  58 %verbose
  59 %pos SourcePos.t
  60 %eop EOF
  61 %noshift EOF
  62
  63 %header (functor MLBLrValsFun (structure Token: TOKEN
  64                                structure Ast: AST
  65                                val lexAndParseProgOrMLB: File.t * Region.t ->
  66                                                          Ast.Basdec.node))
  67
  68 %right AND
  69
  70 %name MLB
  71
  72 %keyword AND BAS BASIS END FUNCTOR IN LET LOCAL OPEN SIGNATURE STRUCTURE ANN PRIM
  73
  74 %change -> SEMICOLON | -> IN ID END
  75
  76 %value ID ("bogus")
  77
  78 %%
  79
  80 mlb : basdecs (basdecs)
  81
  82
  83 basdecs : basdecsnode (Basdec.makeRegion'
  84                        (basdecsnode, basdecsnodeleft, basdecsnoderight))
  85
  86 basdecsnode :                    (Basdec.Seq [])
  87             | SEMICOLON basdecs  (Basdec.Seq [basdecs])
  88             | basdec basdecs     (Basdec.Seq [basdec, basdecs])
  89
  90 basdec : basdecnode (Basdec.makeRegion'
  91                      (basdecnode, basdecnodeleft, basdecnoderight))
  92
  93 basdecnode
  94    : FUNCTOR fctbinds
  95      (let
  96          val fctbinds = Vector.fromList fctbinds
  97       in
  98          Basdec.Defs (ModIdBind.makeRegion' (ModIdBind.Fct fctbinds, FUNCTORleft, fctbindsright))
  99       end)
 100    | SIGNATURE sigbinds
 101      (let
 102          val sigbinds = Vector.fromList sigbinds
 103       in
 104          Basdec.Defs (ModIdBind.makeRegion' (ModIdBind.Sig sigbinds, SIGNATUREleft, sigbindsright))
 105       end)
 106    | STRUCTURE strbinds
 107      (let
 108          val strbinds = Vector.fromList strbinds
 109       in
 110          Basdec.Defs (ModIdBind.makeRegion' (ModIdBind.Str strbinds, STRUCTUREleft, strbindsright))
 111       end)
 112    | BASIS basbinds
 113      (let
 114          val basbinds = Vector.fromList basbinds
 115       in
 116          Basdec.Basis basbinds
 117       end)
 118    | LOCAL basdecs IN basdecs END  (Basdec.Local (basdecs1, basdecs2))
 119    | OPEN basids  (Basdec.Open (Vector.fromList basids))
 120    | FILE
 121      (let val reg = reg (FILEleft, FILEright)
 122       in lexAndParseProgOrMLB (FILE, reg)
 123       end)
 124    | STRING
 125      (let val reg = reg (STRINGleft, STRINGright)
 126       in lexAndParseProgOrMLB (STRING, reg)
 127       end)
 128    | PRIM (Basdec.Prim)
 129    | ANN annPlus IN basdecs END
 130      (let
 131         val extendRight =
 132           let val right = valOf (Region.right (Basdec.region basdecs))
 133           in fn reg => Region.extendRight (reg, right)
 134           end
 135         fun mkAnn' ((ann,reg), basdecs) = Basdec.Ann (ann, reg, basdecs)
 136         fun mkAnn ((ann,reg), basdecsnode) : Basdec.node =
 137           mkAnn' ((ann,reg), Basdec.makeRegion (basdecsnode, extendRight reg))
 138         val (anns,ann) = List.splitLast annPlus
 139       in
 140         List.fold(anns, mkAnn'(ann, basdecs), mkAnn)
 141       end)
 142
 143
 144 fctbinds : fctid EQUALOP fctbinds'
 145            (let val (def, fctbinds) = fctbinds'
 146             in {lhs = fctid, rhs = def}
 147                :: fctbinds
 148             end)
 149          | fctid fctbinds''
 150            ({lhs = fctid, rhs = fctid} :: fctbinds'')
 151
 152 fctbinds' : fctid fctbinds''  (fctid, fctbinds'')
 153
 154 fctbinds'' :               ([])
 155            | AND fctbinds  (fctbinds)
 156
 157 sigbinds : sigid EQUALOP sigbinds'
 158            (let val (def, sigbinds) = sigbinds'
 159             in {lhs = sigid, rhs = def}
 160                :: sigbinds
 161             end)
 162          | sigid sigbinds''
 163            ({lhs = sigid, rhs = sigid} :: sigbinds'')
 164
 165 sigbinds' : sigid sigbinds''  (sigid, sigbinds'')
 166
 167 sigbinds'' :               ([])
 168            | AND sigbinds  (sigbinds)
 169
 170 strbinds : strid EQUALOP strbinds'
 171            (let val (def, strbinds) = strbinds'
 172             in {lhs = strid, rhs = def}
 173                :: strbinds
 174             end)
 175          | strid strbinds''
 176            ({lhs = strid, rhs = strid} :: strbinds'')
 177
 178 strbinds' : strid strbinds''  (strid, strbinds'')
 179
 180 strbinds'' :               ([])
 181            | AND strbinds  (strbinds)
 182
 183 basbinds : basid EQUALOP basbinds'
 184            (let val (def, basbinds) = basbinds'
 185             in {name = basid, def = def}
 186                :: basbinds
 187             end)
 188
 189 basbinds' : basexp basbinds''  (basexp, basbinds'')
 190
 191 basbinds'' :               ([])
 192            | AND basbinds  (basbinds)
 193
 194
 195 basexp : basexpnode (Basexp.makeRegion'
 196                      (basexpnode, basexpnodeleft, basexpnoderight))
 197
 198 basexpnode : BAS basdecs END           (Basexp.Bas basdecs)
 199            | basid                     (Basexp.Var basid)
 200            | LET basdecs IN basexp END (Basexp.Let (basdecs, basexp))
 201
 202 basid : id  (Basid.fromSymbol id)
 203 basids : basid ([basid])
 204        | basid basids (basid :: basids)
 205 fctid : id  (Fctid.fromSymbol id)
 206 sigid : id  (Sigid.fromSymbol id)
 207 strid : id  (Strid.fromSymbol id)
 208 id : ID     (Symbol.fromString ID, reg (IDleft, IDright))
 209
 210
 211 ann : STRING  (STRING, reg (STRINGleft, STRINGright))
 212
 213 annPlus : ann annStar (ann::annStar)
 214
 215 annStar :          ([])
 216         | annPlus  (annPlus)