mlyacc/src/graph.sml

   1 (* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi *)
   2
   3 functor mkGraph(structure IntGrammar : INTGRAMMAR
   4                 structure Core : CORE
   5                 structure CoreUtils : CORE_UTILS
   6                 sharing IntGrammar = Core.IntGrammar = CoreUtils.IntGrammar
   7                 sharing CoreUtils.Core = Core
   8                 ) : LRGRAPH =
   9         struct
  10                 val sub = Array.sub
  11                 infix 9 sub
  12                 structure Core = Core
  13                 structure Grammar = IntGrammar.Grammar
  14                 structure IntGrammar = IntGrammar
  15                 open Core Core.Grammar CoreUtils IntGrammar
  16
  17                 structure NodeSet = RbOrdSet
  18                         (struct
  19                                 type elem = core
  20                                 val eq = eqCore
  21                                 val gt = gtCore
  22                         end)
  23
  24                 open NodeSet
  25                 exception Shift of int * symbol
  26
  27                 type graph = {edges: {edge:symbol,to:core} list array,
  28                               nodes: core list,nodeArray : core array}
  29                 val edges = fn (CORE (_,i),{edges,...}:graph) => edges sub i
  30                 val nodes = fn ({nodes,...} : graph) => nodes
  31                 val shift = fn ({edges,nodes,...} : graph) => fn a as (i,sym) =>
  32                         let fun find nil = raise (Shift a)
  33                               | find ({edge,to=CORE (_,state)} :: r) =
  34                                         if gtSymbol(sym,edge) then find r
  35                                         else if eqSymbol(edge,sym) then state
  36                                         else raise (Shift a)
  37                         in find (edges sub i)
  38                         end
  39
  40                 val core = fn ({nodeArray,...} : graph) =>
  41                                  fn i => nodeArray sub i
  42
  43                 val mkGraph = fn (g as (GRAMMAR {start,...})) =>
  44                    let val {shifts,produces,rules,epsProds} =
  45                                   CoreUtils.mkFuncs g
  46                        fun add_goto ((symbol,a),(nodes,edges,future,num)) =
  47                                 case find(CORE (a,0),nodes)
  48                                   of NONE =>
  49                                      let val core =CORE (a,num)
  50                                          val edge = {edge=symbol,to=core}
  51                                      in (insert(core,nodes),edge::edges,
  52                                          core::future,num+1)
  53                                      end
  54                                    | (SOME c) =>
  55                                         let val edge={edge=symbol,to=c}
  56                                         in (nodes,edge::edges,future,num)
  57                                         end
  58                        fun f (nodes,node_list,edge_list,nil,nil,num) =
  59                             let val nodes=rev node_list
  60                             in {nodes=nodes,
  61                                 edges=Array.fromList (rev edge_list),
  62                                 nodeArray = Array.fromList nodes
  63                                 }
  64                             end
  65                          | f (nodes,node_list,edge_list,nil,y,num) =
  66                                 f (nodes,node_list,edge_list,rev y,nil,num)
  67                          | f (nodes,node_list,edge_list,h::t,y,num) =
  68                                 let val (nodes,edges,future,num) =
  69                                    List.foldr add_goto (nodes,[],y,num) (shifts h)
  70                                 in f (nodes,h::node_list,
  71                                        edges::edge_list,t,future,num)
  72                                 end
  73                 in {graph=
  74                    let val makeItem = fn (r as (RULE {rhs,...})) =>
  75                                                 ITEM{rule=r,dot=0,rhsAfter=rhs}
  76                         val initialItemList = map makeItem (produces start)
  77                         val orderedItemList =
  78                            List.foldr Core.insert [] initialItemList
  79                         val initial = CORE (orderedItemList,0)
  80                    in f(empty,nil,nil,[initial],nil,1)
  81                    end,
  82                    produces=produces,
  83                    rules=rules,
  84                    epsProds=epsProds}
  85                 end
  86         val prGraph = fn a as (nontermToString,termToString,print) => fn g =>
  87            let val printCore = prCore a
  88                val printSymbol = print o nontermToString
  89                val nodes = nodes g
  90                val printEdges = fn n =>
  91                  List.app (fn {edge,to=CORE (_,state)} =>
  92                         (print "\tshift on ";
  93                          printSymbol edge;
  94                          print " to ";
  95                          print (Int.toString state);
  96                          print "\n")) (edges (n,g))
  97          in List.app (fn c => (printCore c; print "\n"; printEdges c)) nodes
  98          end
  99 end;