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