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/trunk/src/ml-yacc/src/shrink.sml
ViewVC logotype

Annotation of /sml/trunk/src/ml-yacc/src/shrink.sml

Parent Directory Parent Directory | Revision Log Revision Log


Revision 250 - (view) (download)

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

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