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) 1991 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/05/30  17:52:58  dbm
17 * Lifted a let to a local in definition of createEquivalences to conform with
18 * value restriction.
19 *
20 * Revision 1.1.1.1  1996/01/31  16:01:46  george
21 * Version 109
22 *
23 *)
24
25signature SORT_ARG =
26  sig
27     type entry
28     val gt : entry * entry -> bool
29  end
30signature SORT =
31  sig
32     type entry
33     val sort : entry list -> entry list
34  end
35signature EQUIV_ARG =
36   sig
37     type entry
38     val gt : entry * entry -> bool
39     val eq : entry * entry -> bool
40   end
41signature EQUIV =
42  sig
43     type entry
44
45     (* equivalences: take a list of entries and divides them into
46        equivalence classes numbered 0 to n-1.
47
48        It returns a triple consisting of:
49
50	  * the number of equivalence classes
51          * a list which maps each original entry to an equivalence
52            class.  The nth entry in this list gives the equivalence
53            class for the nth entry in the original entry list.
54          * a list which maps equivalence classes to some representative
55            element.  The nth entry in this list is an element from the
56            nth equivalence class
57      *)
58
59     val equivalences : entry list -> (int * int list * entry list)
60  end
61
62(* An O(n lg n) merge sort routine *)
63
64functor MergeSortFun(A : SORT_ARG) : SORT =
65  struct
66      type entry = A.entry
67
68      (* sort: an O(n lg n) merge sort routine.  We create a list of lists
69         and then merge these lists in passes until only one list is left.*)
70
71      fun sort nil = nil
72        | sort l =
73             let (* merge: merge two lists *)
74
75                 fun merge (l as a::at,r as b::bt) =
76                       if A.gt(a,b)
77                       then b :: merge(l,bt)
78                       else a :: merge(at,r)
79                   | merge (l,nil) = l
80                   | merge (nil,r) = r
81
82                 (* scan: merge pairs of lists on a list of lists.
83                    Reduces the number of lists by about 1/2 *)
84
85                 fun scan (a :: b :: rest) = merge(a,b) :: scan rest
86                   | scan l = l
87
88	         (* loop: calls scan on a list of lists until only
89                    one list is left.  It terminates only if the list of
90                    lists is nonempty.  (The pattern match for sort
91                    ensures this.) *)
92
93                 fun loop (a :: nil) = a
94                   | loop l = loop (scan l)
95
96              in loop (map (fn a => [a]) l)
97              end
98   end
99
100(* an O(n lg n) routine for placing items in equivalence classes *)
101
102functor EquivFun(A : EQUIV_ARG) : EQUIV =
103   struct
104       open Array List
105       infix 9 sub
106
107      (* Our algorithm for finding equivalence class is simple.  The basic
108         idea is to sort the entries and place duplicates entries in the same
109          equivalence class.
110
111         Let the original entry list be E.  We map E to a list of a pairs
112         consisting of the entry and its position in E, where the positions
113         are numbered 0 to n-1.  Call this list of pairs EP.
114
115         We then sort EP on the original entries.  The second elements in the
116         pairs now specify a permutation that will return us to EP.
117
118         We then scan the sorted list to create a list R of representative
119         entries, a list P of integers which permutes the sorted list back to
120         the original list and a list SE of integers  which gives the
121         equivalence class for the nth entry in the sorted list .
122
123         We then return the length of R, R, and the list that results from
124         permuting SE by P.
125     *)
126
127       type entry = A.entry
128
129       val gt = fn ((a,_),(b,_)) => A.gt(a,b)
130
131       structure Sort = MergeSortFun(type entry = A.entry * int
132     				     val gt = gt)
133       val assignIndex =
134          fn l =>
135             let fun loop (index,nil) = nil
136                   | loop (index,h :: t) = (h,index) :: loop(index+1,t)
137             in loop (0: int,l)
138             end
139
140       local fun loop ((e,_) :: t, prev, class, R , SE: int list) =
141	       if A.eq(e,prev)
142		 then loop(t,e,class,R, class :: SE)
143		 else loop(t,e,class+1,e :: R, (class + 1) :: SE)
144	     | loop (nil,_,_,R,SE) = (rev R, rev SE)
145       in val createEquivalences =
146	   fn nil => (nil,nil)
147	    | (e,_) :: t => loop(t, e, 0, [e],[0: int])
148       end
149
150       val inversePermute = fn permutation =>
151              fn nil => nil
152               | l as h :: _ =>
153                   let val result = array(length l,h)
154                       fun loop (elem :: r, dest :: s) =
155			     (update(result,dest,elem); loop(r,s))
156                         | loop _ = ()
157                       fun listofarray(i: int): int list =
158			  if i < Array.length result then
159				(result sub i) :: listofarray (i+1)
160                          else nil
161                    in loop (l,permutation); listofarray 0
162		    end
163
164       fun makePermutation x = map (fn (_,b) => b) x
165
166       val equivalences = fn l =>
167	   let val EP = assignIndex l
168	       val sorted = Sort.sort EP
169               val P = makePermutation sorted
170               val (R, SE) = createEquivalences sorted
171            in (length R, inversePermute P SE, R)
172            end
173end
174
175functor ShrinkLrTableFun(structure LrTable : LR_TABLE) : SHRINK_LR_TABLE =
176    struct
177	structure LrTable = LrTable
178        open LrTable
179        val gtAction = fn (a,b) =>
180	      case a
181              of SHIFT (STATE s) =>
182		   (case b of SHIFT (STATE s') => s>s' | _ => true)
183               | REDUCE i => (case b of SHIFT _ => false | REDUCE i' => i>i'
184                                      | _ => true)
185               | ACCEPT => (case b of ERROR => true | _ => false)
186               | ERROR =>  false
187        structure ActionEntryList =
188	    struct
189		type entry = (term,action) pairlist * action
190		val rec eqlist =
191                      fn (EMPTY,EMPTY) => true
192                       | (PAIR (T t,d,r),PAIR(T t',d',r')) =>
193                             t=t' andalso d=d' andalso eqlist(r,r')
194                       | _ => false
195                 val rec gtlist =
196                            fn (PAIR _,EMPTY) => true
197                             | (PAIR(T t,d,r),PAIR(T t',d',r')) =>
198				     t>t' orelse (t=t' andalso
199                                       (gtAction(d,d') orelse
200					 (d=d' andalso gtlist(r,r'))))
201                             | _ => false
202		 val eq = fn ((l,a),(l',a')) => a=a' andalso eqlist(l,l')
203                 val gt = fn ((l,a),(l',a')) => gtAction(a,a')
204		                orelse (a=a' andalso gtlist(l,l'))
205            end
206(*        structure GotoEntryList =
207            struct
208	       type entry = (nonterm,state) pairlist
209	       val rec eq =
210                    fn (EMPTY,EMPTY) => true
211                     | (PAIR (t,d,r),PAIR(t',d',r')) =>
212                            t=t' andalso d=d' andalso eq(r,r')
213                     | _ => false
214               val rec gt =
215                    fn (PAIR _,EMPTY) => true
216                     | (PAIR(NT t,STATE d,r),PAIR(NT t',STATE d',r')) =>
217                           t>t' orelse (t=t' andalso
218                           (d>d' orelse (d=d' andalso gt(r,r'))))
219                     | _ => false
220            end *)
221        structure EquivActionList = EquivFun(ActionEntryList)
222        val states = fn max =>
223	    let fun f i=if i<max then STATE i :: f(i+1) else nil
224            in f 0
225            end
226        val length : ('a,'b) pairlist -> int =
227           fn l =>
228	     let fun g(EMPTY,len) = len
229                   | g(PAIR(_,_,r),len) = g(r,len+1)
230             in g(l,0)
231             end
232        val size : (('a,'b) pairlist * 'c) list -> int =
233	   fn l =>
234	     let val c = ref 0
235             in (app (fn (row,_) => c := !c + length row) l; !c)
236             end
237       val shrinkActionList =
238	 fn (table,verbose) =>
239	   case EquivActionList.equivalences
240	             (map (describeActions table) (states (numStates table)))
241           of result as (_,_,l) => (result,if verbose then size l else 0)
242end;
243