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/branches/SMLNJ/src/ml-yacc/src/mklrtable.sml
ViewVC logotype

Annotation of /sml/branches/SMLNJ/src/ml-yacc/src/mklrtable.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 93 - (view) (download)

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

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