| 1 | (* ML-Yacc Parser Generator (c) 1989 Andrew W. Appel, David R. Tarditi *) |
| 2 | |
| 3 | functor mkMakeLrTable (structure IntGrammar : INTGRAMMAR |
| 4 | structure LrTable : LR_TABLE |
| 5 | sharing type LrTable.term = IntGrammar.Grammar.term |
| 6 | sharing type LrTable.nonterm = IntGrammar.Grammar.nonterm |
| 7 | ) : MAKE_LR_TABLE = |
| 8 | struct |
| 9 | val sub = Array.sub |
| 10 | infix 9 sub |
| 11 | structure Core = mkCore(structure IntGrammar = IntGrammar) |
| 12 | structure CoreUtils = mkCoreUtils(structure IntGrammar = IntGrammar |
| 13 | structure Core = Core) |
| 14 | structure Graph = mkGraph(structure IntGrammar = IntGrammar |
| 15 | structure Core = Core |
| 16 | structure CoreUtils = CoreUtils) |
| 17 | structure Look = mkLook(structure IntGrammar = IntGrammar) |
| 18 | structure Lalr = mkLalr(structure IntGrammar = IntGrammar |
| 19 | structure Core = Core |
| 20 | structure Graph = Graph |
| 21 | structure Look = Look) |
| 22 | structure LrTable = LrTable |
| 23 | structure IntGrammar = IntGrammar |
| 24 | structure Grammar = IntGrammar.Grammar |
| 25 | structure GotoList = ListOrdSet |
| 26 | (struct |
| 27 | type elem = Grammar.nonterm * LrTable.state |
| 28 | val eq = fn ((Grammar.NT a,_),(Grammar.NT b,_)) => a=b |
| 29 | val gt = fn ((Grammar.NT a,_),(Grammar.NT b,_)) => a>b |
| 30 | end) |
| 31 | structure Errs : LR_ERRS = |
| 32 | struct |
| 33 | structure LrTable = LrTable |
| 34 | datatype err = RR of LrTable.term * LrTable.state * int * int |
| 35 | | SR of LrTable.term * LrTable.state * int |
| 36 | | NOT_REDUCED of int |
| 37 | | NS of LrTable.term * int |
| 38 | | START of int |
| 39 | |
| 40 | val summary = fn l => |
| 41 | let val numRR = ref 0 |
| 42 | val numSR = ref 0 |
| 43 | val numSTART = ref 0 |
| 44 | val numNOT_REDUCED = ref 0 |
| 45 | val numNS = ref 0 |
| 46 | fun loop (h::t) = |
| 47 | (case h |
| 48 | of RR _ => numRR := !numRR+1 |
| 49 | | SR _ => numSR := !numSR+1 |
| 50 | | START _ => numSTART := !numSTART+1 |
| 51 | | NOT_REDUCED _ => numNOT_REDUCED := !numNOT_REDUCED+1 |
| 52 | | NS _ => numNS := !numNS+1; loop t) |
| 53 | | loop nil = {rr = !numRR, sr = !numSR, |
| 54 | start = !numSTART, |
| 55 | not_reduced = !numNOT_REDUCED, |
| 56 | nonshift = !numNS} |
| 57 | in loop l |
| 58 | end |
| 59 | |
| 60 | val printSummary = fn say => fn l => |
| 61 | let val {rr,sr,start, |
| 62 | not_reduced,nonshift} = summary l |
| 63 | val say_plural = fn (i,s) => |
| 64 | (say (Int.toString i); say " "; |
| 65 | case i |
| 66 | of 1 => (say s) |
| 67 | | _ => (say s; say "s")) |
| 68 | val say_error = fn (args as (i,s)) => |
| 69 | case i |
| 70 | of 0 => () |
| 71 | | i => (say_plural args; say "\n") |
| 72 | in say_error(rr,"reduce/reduce conflict"); |
| 73 | say_error(sr,"shift/reduce conflict"); |
| 74 | if nonshift<>0 then |
| 75 | (say "non-shiftable terminal used on the rhs of "; |
| 76 | say_plural(start,"rule"); say "\n") |
| 77 | else (); |
| 78 | if start<>0 then (say "start symbol used on the rhs of "; |
| 79 | say_plural(start,"rule"); say "\n") |
| 80 | else (); |
| 81 | if not_reduced<>0 then (say_plural(not_reduced,"rule"); |
| 82 | say " not reduced\n") |
| 83 | else () |
| 84 | end |
| 85 | end |
| 86 | |
| 87 | |
| 88 | open IntGrammar Grammar Errs LrTable Core |
| 89 | |
| 90 | (* rules for resolving conflicts: |
| 91 | |
| 92 | shift/reduce: |
| 93 | |
| 94 | If either the terminal or the rule has no |
| 95 | precedence, a shift/reduce conflict is reported. |
| 96 | A shift is chosen for the table. |
| 97 | |
| 98 | If both have precedences, the action with the |
| 99 | higher precedence is chosen. |
| 100 | |
| 101 | If the precedences are equal, neither the |
| 102 | shift nor the reduce is chosen. |
| 103 | |
| 104 | reduce/reduce: |
| 105 | |
| 106 | A reduce/reduce conflict is reported. The lowest |
| 107 | numbered rule is chosen for reduction. |
| 108 | *) |
| 109 | |
| 110 | |
| 111 | (* method for filling tables - first compute the reductions called for in a |
| 112 | state, then add the shifts for the state to this information. |
| 113 | |
| 114 | How to compute the reductions: |
| 115 | |
| 116 | A reduction initially is given as an item and a lookahead set calling |
| 117 | for reduction by that item. The first reduction is mapped to a list of |
| 118 | terminal * rule pairs. Each additional reduction is then merged into this |
| 119 | list and reduce/reduce conflicts are resolved according to the rule |
| 120 | given. |
| 121 | |
| 122 | Missed Errors: |
| 123 | |
| 124 | This method misses some reduce/reduce conflicts that exist because |
| 125 | some reductions are removed from the list before conflicting reductions |
| 126 | can be compared against them. All reduce/reduce conflicts, however, |
| 127 | can be generated given a list of the reduce/reduce conflicts generated |
| 128 | by this method. |
| 129 | |
| 130 | This can be done by taking the transitive closure of the relation given |
| 131 | by the list. If reduce/reduce (a,b) and reduce/reduce (b,c) are true, |
| 132 | then reduce/reduce (a,c) is true. The relation is symmetric and transitive. |
| 133 | |
| 134 | Adding shifts: |
| 135 | |
| 136 | Finally scan the list merging in shifts and resolving conflicts |
| 137 | according to the rule given. |
| 138 | |
| 139 | Missed Shift/Reduce Errors: |
| 140 | |
| 141 | Some errors may be missed by this method because some reductions were |
| 142 | removed as the result of reduce/reduce conflicts. For a shift/reduce |
| 143 | conflict of term a, reduction by rule n, shift/reduce conficts exist |
| 144 | for all rules y such that reduce/reduce (x,y) or reduce/reduce (y,x) |
| 145 | is true. |
| 146 | *) |
| 147 | |
| 148 | fun unREDUCE (REDUCE num) = num |
| 149 | | unREDUCE _ = raise Fail "bug: unexpected action (expected REDUCE)" |
| 150 | |
| 151 | val mergeReduces = |
| 152 | let val merge = fn state => |
| 153 | let fun f (j as (pair1 as (T t1,action1)) :: r1, |
| 154 | k as (pair2 as (T t2,action2)) :: r2,result,errs) = |
| 155 | if t1 < t2 then f(r1,k,pair1::result,errs) |
| 156 | else if t1 > t2 then f(j,r2,pair2::result,errs) |
| 157 | else let val num1 = unREDUCE action1 |
| 158 | val num2 = unREDUCE action2 |
| 159 | val errs = RR(T t1,state,num1,num2) :: errs |
| 160 | val action = if num1 < num2 then pair1 else pair2 |
| 161 | in f(r1,r2,action::result,errs) |
| 162 | end |
| 163 | | f (nil,nil,result,errs) = (rev result,errs) |
| 164 | | f (pair1::r,nil,result,errs) = f(r,nil,pair1::result,errs) |
| 165 | | f (nil,pair2 :: r,result,errs) = f(nil,r,pair2::result,errs) |
| 166 | in f |
| 167 | end |
| 168 | in fn state => fn ((ITEM {rule=RULE {rulenum,...},...}, lookahead), |
| 169 | (reduces,errs)) => |
| 170 | let val action = REDUCE rulenum |
| 171 | val actions = map (fn a=>(a,action)) lookahead |
| 172 | in case reduces |
| 173 | of nil => (actions,errs) |
| 174 | | _ => merge state (reduces,actions,nil,errs) |
| 175 | end |
| 176 | end |
| 177 | |
| 178 | val computeActions = fn (rules,precedence,graph,defaultReductions) => |
| 179 | |
| 180 | let val rulePrec = |
| 181 | let val precData = Array.array(length rules,NONE : int option) |
| 182 | in app (fn RULE {rulenum=r,precedence=p,...} => Array.update(precData,r,p)) |
| 183 | rules; |
| 184 | fn i => precData sub i |
| 185 | end |
| 186 | |
| 187 | fun mergeShifts(state,shifts,nil) = (shifts,nil) |
| 188 | | mergeShifts(state,nil,reduces) = (reduces,nil) |
| 189 | | mergeShifts(state,shifts,reduces) = |
| 190 | let fun f(shifts as (pair1 as (T t1,_)) :: r1, |
| 191 | reduces as (pair2 as (T t2,action)) :: r2, |
| 192 | result,errs) = |
| 193 | if t1 < t2 then f(r1,reduces,pair1 :: result,errs) |
| 194 | else if t1 > t2 then f(shifts,r2,pair2 :: result,errs) |
| 195 | else let val rulenum = unREDUCE action |
| 196 | val (term1,_) = pair1 |
| 197 | in case (precedence term1,rulePrec rulenum) |
| 198 | of (SOME i,SOME j) => |
| 199 | if i>j then f(r1,r2,pair1 :: result,errs) |
| 200 | else if j>i then f(r1,r2,pair2 :: result,errs) |
| 201 | else f(r1,r2,(T t1, ERROR)::result,errs) |
| 202 | | (_,_) => |
| 203 | f(r1,r2,pair1 :: result, |
| 204 | SR (term1,state,rulenum)::errs) |
| 205 | end |
| 206 | | f (nil,nil,result,errs) = (rev result,errs) |
| 207 | | f (nil,h::t,result,errs) = |
| 208 | f (nil,t,h::result,errs) |
| 209 | | f (h::t,nil,result,errs) = |
| 210 | f (t,nil,h::result,errs) |
| 211 | in f(shifts,reduces,nil,nil) |
| 212 | end |
| 213 | |
| 214 | fun mapCore ({edge=symbol,to=CORE (_,state)}::r,shifts,gotos) = |
| 215 | (case symbol |
| 216 | of (TERM t) => mapCore (r,(t,SHIFT(STATE state))::shifts,gotos) |
| 217 | | (NONTERM nt) => mapCore(r,shifts,(nt,STATE state)::gotos) |
| 218 | ) |
| 219 | | mapCore (nil,shifts,gotos) = (rev shifts,rev gotos) |
| 220 | |
| 221 | fun pruneError ((_,ERROR)::rest) = pruneError rest |
| 222 | | pruneError (a::rest) = a :: pruneError rest |
| 223 | | pruneError nil = nil |
| 224 | |
| 225 | in fn (Lalr.LCORE (reduceItems,state),c as CORE (shiftItems,state')) => |
| 226 | if DEBUG andalso (state <> state') then |
| 227 | let exception MkTable in raise MkTable end |
| 228 | else |
| 229 | let val (shifts,gotos) = mapCore (Graph.edges(c,graph),nil,nil) |
| 230 | val tableState = STATE state |
| 231 | in case reduceItems |
| 232 | of nil => ((shifts,ERROR),gotos,nil) |
| 233 | | h :: nil => |
| 234 | let val (ITEM {rule=RULE {rulenum,...},...}, l) = h |
| 235 | val (reduces,_) = mergeReduces tableState (h,(nil,nil)) |
| 236 | val (actions,errs) = mergeShifts(tableState, |
| 237 | shifts,reduces) |
| 238 | val actions' = pruneError actions |
| 239 | val (actions,default) = |
| 240 | let fun hasReduce (nil,actions) = |
| 241 | (rev actions,REDUCE rulenum) |
| 242 | | hasReduce ((a as (_,SHIFT _)) :: r,actions) = |
| 243 | hasReduce(r,a::actions) |
| 244 | | hasReduce (_ :: r,actions) = |
| 245 | hasReduce(r,actions) |
| 246 | fun loop (nil,actions) = (rev actions,ERROR) |
| 247 | | loop ((a as (_,SHIFT _)) :: r,actions) = |
| 248 | loop(r,a::actions) |
| 249 | | loop ((a as (_,REDUCE _)) :: r,actions) = |
| 250 | hasReduce(r,actions) |
| 251 | | loop (_ :: r,actions) = loop(r,actions) |
| 252 | in if defaultReductions |
| 253 | andalso length actions = length actions' |
| 254 | then loop(actions,nil) |
| 255 | else (actions',ERROR) |
| 256 | end |
| 257 | in ((actions,default), gotos,errs) |
| 258 | end |
| 259 | | l => |
| 260 | let val (reduces,errs1) = |
| 261 | List.foldr (mergeReduces tableState) (nil,nil) l |
| 262 | val (actions,errs2) = |
| 263 | mergeShifts(tableState,shifts,reduces) |
| 264 | in ((pruneError actions,ERROR),gotos,errs1@errs2) |
| 265 | end |
| 266 | end |
| 267 | end |
| 268 | |
| 269 | val mkTable = fn (grammar as GRAMMAR{rules,terms,nonterms,start, |
| 270 | precedence,termToString,noshift, |
| 271 | nontermToString,eop},defaultReductions) => |
| 272 | let val symbolToString = fn (TERM t) => termToString t |
| 273 | | (NONTERM nt) => nontermToString nt |
| 274 | val {rules,graph,produces,epsProds,...} = Graph.mkGraph grammar |
| 275 | val {nullable,first} = |
| 276 | Look.mkFuncs{rules=rules,produces=produces,nonterms=nonterms} |
| 277 | val lcores = Lalr.addLookahead |
| 278 | {graph=graph, |
| 279 | nullable=nullable, |
| 280 | produces=produces, |
| 281 | eop=eop, |
| 282 | nonterms=nonterms, |
| 283 | first=first, |
| 284 | rules=rules, |
| 285 | epsProds=epsProds, |
| 286 | print=(fn s=>TextIO.output(TextIO.stdOut,s)), |
| 287 | termToString = termToString, |
| 288 | nontermToString = nontermToString} |
| 289 | |
| 290 | fun zip (h::t,h'::t') = (h,h') :: zip(t,t') |
| 291 | | zip (nil,nil) = nil |
| 292 | | zip _ = let exception MkTable in raise MkTable end |
| 293 | |
| 294 | fun unzip l = |
| 295 | let fun f ((a,b,c)::r,j,k,l) = f(r,a::j,b::k,c::l) |
| 296 | | f (nil,j,k,l) = (rev j,rev k,rev l) |
| 297 | in f(l,nil,nil,nil) |
| 298 | end |
| 299 | |
| 300 | val (actions,gotos,errs) = |
| 301 | let val doState = |
| 302 | computeActions(rules,precedence,graph, |
| 303 | defaultReductions) |
| 304 | in unzip (map doState (zip(lcores,Graph.nodes graph))) |
| 305 | end |
| 306 | |
| 307 | (* add goto from state 0 to a new state. The new state |
| 308 | has accept actions for all of the end-of-parse symbols *) |
| 309 | |
| 310 | val (actions,gotos,errs) = |
| 311 | case gotos |
| 312 | of nil => (actions,gotos,errs) |
| 313 | | h :: t => |
| 314 | let val newStateActions = |
| 315 | (map (fn t => (t,ACCEPT)) (Look.make_set eop),ERROR) |
| 316 | val state0Goto = |
| 317 | GotoList.insert((start,STATE (length actions)),h) |
| 318 | in (actions @ [newStateActions], |
| 319 | state0Goto :: (t @ [nil]), |
| 320 | errs @ [nil]) |
| 321 | end |
| 322 | |
| 323 | val startErrs = |
| 324 | List.foldr (fn (RULE {rhs,rulenum,...},r) => |
| 325 | if (List.exists (fn NONTERM a => a=start |
| 326 | | _ => false) rhs) |
| 327 | then START rulenum :: r |
| 328 | else r) [] rules |
| 329 | |
| 330 | val nonshiftErrs = |
| 331 | List.foldr (fn (RULE {rhs,rulenum,...},r) => |
| 332 | (List.foldr (fn (nonshift,r) => |
| 333 | if (List.exists (fn TERM a => a=nonshift |
| 334 | | _ => false) rhs) |
| 335 | then NS(nonshift,rulenum) :: r |
| 336 | else r) r noshift) |
| 337 | ) [] rules |
| 338 | |
| 339 | val notReduced = |
| 340 | let val ruleReduced = Array.array(length rules,false) |
| 341 | val test = fn REDUCE i => Array.update(ruleReduced,i,true) |
| 342 | | _ => () |
| 343 | val _ = app (fn (actions,default) => |
| 344 | (app (fn (_,r) => test r) actions; |
| 345 | test default) |
| 346 | ) actions; |
| 347 | fun scan (i,r) = |
| 348 | if i >= 0 then |
| 349 | scan(i-1, if ruleReduced sub i then r |
| 350 | else NOT_REDUCED i :: r) |
| 351 | else r |
| 352 | in scan(Array.length ruleReduced-1,nil) |
| 353 | end handle Subscript => |
| 354 | (if DEBUG then |
| 355 | print "rules not numbered correctly!" |
| 356 | else (); nil) |
| 357 | |
| 358 | val numstates = length actions |
| 359 | |
| 360 | val allErrs = startErrs @ notReduced @ nonshiftErrs @ |
| 361 | (List.concat errs) |
| 362 | |
| 363 | fun convert_to_pairlist(nil : ('a * 'b) list): ('a,'b) pairlist = |
| 364 | EMPTY |
| 365 | | convert_to_pairlist ((a,b) :: r) = |
| 366 | PAIR(a,b,convert_to_pairlist r) |
| 367 | |
| 368 | in (mkLrTable {actions=Array.fromList(map (fn (a,b) => |
| 369 | (convert_to_pairlist a,b)) actions), |
| 370 | gotos=Array.fromList (map convert_to_pairlist gotos), |
| 371 | numRules=length rules,numStates=length actions, |
| 372 | initialState=STATE 0}, |
| 373 | let val errArray = Array.fromList errs |
| 374 | in fn (STATE state) => errArray sub state |
| 375 | end, |
| 376 | |
| 377 | fn print => |
| 378 | let val printCore = |
| 379 | prCore(symbolToString,nontermToString,print) |
| 380 | val core = Graph.core graph |
| 381 | in fn STATE state => |
| 382 | printCore (if state=(numstates-1) then |
| 383 | Core.CORE (nil,state) |
| 384 | else (core state)) |
| 385 | end, |
| 386 | allErrs) |
| 387 | end |
| 388 | end; |