1(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi
2 *
3 * $Log$
4 * Revision 1.1  2006/06/22 07:40:27  michaeln
5 * Add a MoscowML compilable implementation of MLyacc, using the MLton sources
6 * as the base.
7 *
8 * Revision 1.1.1.1  1997/01/14 01:38:05  george
9 *   Version 109.24
10 *
11 * Revision 1.2  1996/02/26  15:02:34  george
12 *    print no longer overloaded.
13 *    use of makestring has been removed and replaced with Int.toString ..
14 *    use of IO replaced with TextIO
15 *
16 * Revision 1.1.1.1  1996/01/31  16:01:45  george
17 * Version 109
18 *
19 *)
20
21functor mkGraph(structure IntGrammar : INTGRAMMAR
22		structure Core : CORE
23		structure CoreUtils : CORE_UTILS
24		sharing IntGrammar = Core.IntGrammar = CoreUtils.IntGrammar
25		sharing CoreUtils.Core = Core
26		) : LRGRAPH =
27	struct
28	        open Array List
29		infix 9 sub
30		structure Core = Core
31		structure Grammar = IntGrammar.Grammar
32		structure IntGrammar = IntGrammar
33		open Core Core.Grammar CoreUtils IntGrammar
34
35		structure NodeSet = RbOrdSet
36			(struct
37				type elem = core
38				val eq = eqCore
39				val gt = gtCore
40			end)
41
42		open NodeSet
43		exception Shift of int * symbol
44
45		type graph = {edges: {edge:symbol,to:core} list array,
46			      nodes: core list,nodeArray : core array}
47		val edges = fn (CORE (_,i),{edges,...}:graph) => edges sub i
48		val nodes = fn ({nodes,...} : graph) => nodes
49		val shift = fn ({edges,nodes,...} : graph) => fn a as (i,sym) =>
50			let fun find nil = raise (Shift a)
51			      | find ({edge,to=CORE (_,state)} :: r) =
52					if gtSymbol(sym,edge) then find r
53					else if eqSymbol(edge,sym) then state
54					else raise (Shift a)
55			in find (edges sub i)
56			end
57
58		val core = fn ({nodeArray,...} : graph) =>
59				 fn i => nodeArray sub i
60
61		val mkGraph = fn (g as (GRAMMAR {start,...})) =>
62		   let val {shifts,produces,rules,epsProds} =
63				  CoreUtils.mkFuncs g
64		       fun add_goto ((symbol,a),(nodes,edges,future,num)) =
65				case find(CORE (a,0),nodes)
66				  of NONE =>
67				     let val core =CORE (a,num)
68					 val edge = {edge=symbol,to=core}
69				     in (insert(core,nodes),edge::edges,
70					 core::future,num+1)
71				     end
72				   | (SOME c) =>
73					let val edge={edge=symbol,to=c}
74					in (nodes,edge::edges,future,num)
75					end
76		       fun f (nodes,node_list,edge_list,nil,nil,num) =
77			    let val nodes=rev node_list
78			    in {nodes=nodes,
79				edges=Array.fromList (rev edge_list),
80				nodeArray = Array.fromList nodes
81			 	}
82			    end
83			 | f (nodes,node_list,edge_list,nil,y,num) =
84				f (nodes,node_list,edge_list,rev y,nil,num)
85			 | f (nodes,node_list,edge_list,h::t,y,num) =
86			 	let val (nodes,edges,future,num) =
87				   List.foldr add_goto (nodes,[],y,num) (shifts h)
88				in f (nodes,h::node_list,
89				       edges::edge_list,t,future,num)
90				end
91		in {graph=
92		   let val makeItem = fn (r as (RULE {rhs,...})) =>
93						ITEM{rule=r,dot=0,rhsAfter=rhs}
94			val initialItemList = map makeItem (produces start)
95		        val orderedItemList =
96			   List.foldr Core.insert [] initialItemList
97 			val initial = CORE (orderedItemList,0)
98		   in f(empty,nil,nil,[initial],nil,1)
99		   end,
100		   produces=produces,
101		   rules=rules,
102		   epsProds=epsProds}
103		end
104	val prGraph = fn a as (nontermToString,termToString,print) => fn g =>
105	   let val printCore = prCore a
106	       val printSymbol = print o nontermToString
107	       val nodes = nodes g
108	       val printEdges = fn n =>
109		 List.app (fn {edge,to=CORE (_,state)} =>
110			(print "\tshift on ";
111			 printSymbol edge;
112			 print " to ";
113			 print (Int.toString state);
114			 print "\n")) (edges (n,g))
115	 in List.app (fn c => (printCore c; print "\n"; printEdges c)) nodes
116	 end
117end;
118