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 113 - (view) (download)

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

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