1(* Modified by sweeks@acm.org on 2000-8-24.
2 * Ported to MLton.
3 *)
4type int = Int.int
5
6(* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi
7 *
8 * $Log$
9 * Revision 1.1  2006/06/22 07:40:27  michaeln
10 * Add a MoscowML compilable implementation of MLyacc, using the MLton sources
11 * as the base.
12 *
13 * Revision 1.1.1.1  1997/01/14 01:38:06  george
14 *   Version 109.24
15 *
16 * Revision 1.2  1996/02/26  15:02:39  george
17 *    print no longer overloaded.
18 *    use of makestring has been removed and replaced with Int.toString ..
19 *    use of IO replaced with TextIO
20 *
21 * Revision 1.1.1.1  1996/01/31  16:01:47  george
22 * Version 109
23 *
24 *)
25
26functor mkVerbose(structure Errs : LR_ERRS) : VERBOSE =
27struct
28   structure Errs = Errs
29   open Errs Errs.LrTable
30   val mkPrintAction = fn print =>
31	let val printInt = print o (Int.toString : int -> string)
32	in fn (SHIFT (STATE i)) =>
33			(print "\tshift ";
34		 	 printInt i;
35		 	print "\n")
36	     | (REDUCE rulenum) =>
37			(print "\treduce by rule ";
38		 	 printInt rulenum;
39		 	 print "\n")
40	     | ACCEPT => print "\taccept\n"
41	     | ERROR => print "\terror\n"
42	end
43   val mkPrintGoto = fn (printNonterm,print) =>
44      let val printInt = print o (Int.toString : int -> string)
45      in fn (nonterm,STATE i) =>
46		(print "\t";
47		 printNonterm nonterm;
48		 print "\tgoto ";
49		 printInt i;
50		 print "\n")
51      end
52
53   val mkPrintTermAction = fn (printTerm,print) =>
54 	let val printAction = mkPrintAction print
55	in fn (term,action) =>
56		(print "\t";
57		 printTerm term;
58		 printAction action)
59	end
60   val mkPrintGoto = fn (printNonterm,print) =>
61	fn (nonterm,STATE i) =>
62	    let val printInt = print o (Int.toString : int -> string)
63	    in (print "\t";
64		printNonterm nonterm;
65		print "\tgoto ";
66		printInt i;
67		print "\n")
68	    end
69   val mkPrintError = fn (printTerm,printRule,print) =>
70     let val printInt = print o (Int.toString : int -> string)
71	 val printState = fn STATE s => (print " state "; printInt s)
72     in fn (RR (term,state,r1,r2)) =>
73		(print "error: ";
74		 printState state;
75		 print ": reduce/reduce conflict between rule ";
76		 printInt r1;
77		 print " and rule ";
78		 printInt r2;
79		 print " on ";
80		 printTerm term;
81		 print "\n")
82	 | (SR (term,state,r1)) =>
83		(print "error: ";
84		 printState state;
85		 print ": shift/reduce conflict ";
86		 print "(shift ";
87		 printTerm term;
88		 print ", reduce by rule ";
89		 printInt r1;
90		 print ")\n")
91	 | NOT_REDUCED i =>
92		(print "warning: rule <";
93		 printRule i;
94		 print "> will never be reduced\n")
95	 | START i =>
96	        (print "warning: start symbol appears on the rhs of ";
97	         print "<";
98	         printRule i;
99		 print ">\n")
100	 | NS (term,i) =>
101	        (print "warning: non-shiftable terminal ";
102		 printTerm term;
103		 print  "appears on the rhs of ";
104	         print "<";
105	         printRule i;
106		 print ">\n")
107      end
108   structure PairList : sig
109                          val app : ('a * 'b -> unit) -> ('a,'b) pairlist -> unit
110                          val length : ('a,'b) pairlist -> int
111                        end
112       =
113      struct
114         val app = fn f =>
115	     let fun g EMPTY = ()
116                   | g (PAIR(a,b,r)) = (f(a,b); g r)
117             in g
118             end
119         val length = fn l =>
120	     let fun g(EMPTY,len) = len
121                   | g(PAIR(_,_,r),len) = g(r,len+1)
122             in g(l,0: int)
123             end
124      end
125   val printVerbose =
126	fn {termToString,nontermToString,table,stateErrs,entries:int,
127	    print,printRule,errs,printCores} =>
128	   let
129		val printTerm = print o termToString
130		val printNonterm = print o nontermToString
131
132		val printCore = printCores print
133		val printTermAction = mkPrintTermAction(printTerm,print)
134		val printAction = mkPrintAction print
135		val printGoto = mkPrintGoto(printNonterm,print)
136		val printError = mkPrintError(printTerm,printRule print,print)
137
138		val gotos = LrTable.describeGoto table
139		val actions = LrTable.describeActions table
140		val states = numStates table
141
142                val gotoTableSize = ref 0
143                val actionTableSize = ref 0
144
145		val _ = if length errs > 0
146			   then (printSummary print errs;
147			         print "\n";
148				 app printError errs)
149			   else ()
150		fun loop i =
151		  if i=states then ()
152		  else let val s = STATE i
153		       in (app printError (stateErrs s);
154			   print "\n";
155			   printCore s;
156			   let val (actionList,default) = actions s
157			       val gotoList = gotos s
158			   in (PairList.app printTermAction actionList;
159			       print "\n";
160			       PairList.app printGoto gotoList;
161			       print "\n";
162			       print "\t.";
163			       printAction default;
164			       print "\n";
165			       gotoTableSize:=(!gotoTableSize)+
166			                      PairList.length gotoList;
167			       actionTableSize := (!actionTableSize) +
168			                       PairList.length actionList + 1
169			       )
170			   end;
171			   loop (i+1))
172			end
173	  in loop 0;
174	      print (Int.toString entries ^ " of " ^
175		     Int.toString (!actionTableSize)^
176		     " action table entries left after compaction\n");
177	      print (Int.toString (!gotoTableSize)^ " goto table entries\n")
178	  end
179end;
180
181
182