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