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