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