Home My Page Projects Code Snippets Project Openings SML/NJ
Summary Activity Forums Tracker Lists Tasks Docs Surveys News SCM Files

SCM Repository

[smlnj] Annotation of /sml/trunk/src/ml-yacc/src/verbose.sml
ViewVC logotype

Annotation of /sml/trunk/src/ml-yacc/src/verbose.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 250 - (view) (download)

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

root@smlnj-gforge.cs.uchicago.edu
ViewVC Help
Powered by ViewVC 1.0.0