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