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