Mercurial > hg > CbC > CbC_gcc

comparison gcc/ada/libgnat/g-dynhta.adb @ 111:04ced10e8804

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
gcc 7
author kono
date Fri, 27 Oct 2017 22:46:09 +0900
parents
children 84e7813d76e9
comparison
equal deleted inserted replaced
68:561a7518be6b 111:04ced10e8804
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT RUN-TIME COMPONENTS --
4 -- --
5 -- G N A T . D Y N A M I C _ H T A B L E S --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2002-2017, AdaCore --
10 -- --
11 -- GNAT is free software; you can redistribute it and/or modify it under --
12 -- terms of the GNU General Public License as published by the Free Soft- --
13 -- ware Foundation; either version 3, or (at your option) any later ver- --
14 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
15 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
16 -- or FITNESS FOR A PARTICULAR PURPOSE. --
17 -- --
18 -- As a special exception under Section 7 of GPL version 3, you are granted --
19 -- additional permissions described in the GCC Runtime Library Exception, --
20 -- version 3.1, as published by the Free Software Foundation. --
21 -- --
22 -- You should have received a copy of the GNU General Public License and --
23 -- a copy of the GCC Runtime Library Exception along with this program; --
24 -- see the files COPYING3 and COPYING.RUNTIME respectively. If not, see --
25 -- <http://www.gnu.org/licenses/>. --
26 -- --
27 -- GNAT was originally developed by the GNAT team at New York University. --
28 -- Extensive contributions were provided by Ada Core Technologies Inc. --
29 -- --
30 ------------------------------------------------------------------------------
31
32 with Ada.Unchecked_Deallocation;
33
34 package body GNAT.Dynamic_HTables is
35
36 -------------------
37 -- Static_HTable --
38 -------------------
39
40 package body Static_HTable is
41
42 function Get_Non_Null (T : Instance) return Elmt_Ptr;
43 -- Returns Null_Ptr if Iterator_Started is False or if the Table is
44 -- empty. Returns Iterator_Ptr if non null, or the next non null
45 -- element in table if any.
46
47 ---------
48 -- Get --
49 ---------
50
51 function Get (T : Instance; K : Key) return Elmt_Ptr is
52 Elmt : Elmt_Ptr;
53
54 begin
55 if T = null then
56 return Null_Ptr;
57 end if;
58
59 Elmt := T.Table (Hash (K));
60
61 loop
62 if Elmt = Null_Ptr then
63 return Null_Ptr;
64
65 elsif Equal (Get_Key (Elmt), K) then
66 return Elmt;
67
68 else
69 Elmt := Next (Elmt);
70 end if;
71 end loop;
72 end Get;
73
74 ---------------
75 -- Get_First --
76 ---------------
77
78 function Get_First (T : Instance) return Elmt_Ptr is
79 begin
80 if T = null then
81 return Null_Ptr;
82 end if;
83
84 T.Iterator_Started := True;
85 T.Iterator_Index := T.Table'First;
86 T.Iterator_Ptr := T.Table (T.Iterator_Index);
87 return Get_Non_Null (T);
88 end Get_First;
89
90 --------------
91 -- Get_Next --
92 --------------
93
94 function Get_Next (T : Instance) return Elmt_Ptr is
95 begin
96 if T = null or else not T.Iterator_Started then
97 return Null_Ptr;
98 end if;
99
100 T.Iterator_Ptr := Next (T.Iterator_Ptr);
101 return Get_Non_Null (T);
102 end Get_Next;
103
104 ------------------
105 -- Get_Non_Null --
106 ------------------
107
108 function Get_Non_Null (T : Instance) return Elmt_Ptr is
109 begin
110 if T = null then
111 return Null_Ptr;
112 end if;
113
114 while T.Iterator_Ptr = Null_Ptr loop
115 if T.Iterator_Index = T.Table'Last then
116 T.Iterator_Started := False;
117 return Null_Ptr;
118 end if;
119
120 T.Iterator_Index := T.Iterator_Index + 1;
121 T.Iterator_Ptr := T.Table (T.Iterator_Index);
122 end loop;
123
124 return T.Iterator_Ptr;
125 end Get_Non_Null;
126
127 ------------
128 -- Remove --
129 ------------
130
131 procedure Remove (T : Instance; K : Key) is
132 Index : constant Header_Num := Hash (K);
133 Elmt : Elmt_Ptr;
134 Next_Elmt : Elmt_Ptr;
135
136 begin
137 if T = null then
138 return;
139 end if;
140
141 Elmt := T.Table (Index);
142
143 if Elmt = Null_Ptr then
144 return;
145
146 elsif Equal (Get_Key (Elmt), K) then
147 T.Table (Index) := Next (Elmt);
148
149 else
150 loop
151 Next_Elmt := Next (Elmt);
152
153 if Next_Elmt = Null_Ptr then
154 return;
155
156 elsif Equal (Get_Key (Next_Elmt), K) then
157 Set_Next (Elmt, Next (Next_Elmt));
158 return;
159
160 else
161 Elmt := Next_Elmt;
162 end if;
163 end loop;
164 end if;
165 end Remove;
166
167 -----------
168 -- Reset --
169 -----------
170
171 procedure Reset (T : in out Instance) is
172 procedure Free is
173 new Ada.Unchecked_Deallocation (Instance_Data, Instance);
174
175 begin
176 if T = null then
177 return;
178 end if;
179
180 for J in T.Table'Range loop
181 T.Table (J) := Null_Ptr;
182 end loop;
183
184 Free (T);
185 end Reset;
186
187 ---------
188 -- Set --
189 ---------
190
191 procedure Set (T : in out Instance; E : Elmt_Ptr) is
192 Index : Header_Num;
193
194 begin
195 if T = null then
196 T := new Instance_Data;
197 end if;
198
199 Index := Hash (Get_Key (E));
200 Set_Next (E, T.Table (Index));
201 T.Table (Index) := E;
202 end Set;
203
204 end Static_HTable;
205
206 -------------------
207 -- Simple_HTable --
208 -------------------
209
210 package body Simple_HTable is
211 procedure Free is new
212 Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr);
213
214 ---------
215 -- Get --
216 ---------
217
218 function Get (T : Instance; K : Key) return Element is
219 Tmp : Elmt_Ptr;
220
221 begin
222 if T = Nil then
223 return No_Element;
224 end if;
225
226 Tmp := Tab.Get (Tab.Instance (T), K);
227
228 if Tmp = null then
229 return No_Element;
230 else
231 return Tmp.E;
232 end if;
233 end Get;
234
235 ---------------
236 -- Get_First --
237 ---------------
238
239 function Get_First (T : Instance) return Element is
240 Tmp : constant Elmt_Ptr := Tab.Get_First (Tab.Instance (T));
241
242 begin
243 if Tmp = null then
244 return No_Element;
245 else
246 return Tmp.E;
247 end if;
248 end Get_First;
249
250 -------------------
251 -- Get_First_Key --
252 -------------------
253
254 function Get_First_Key (T : Instance) return Key_Option is
255 Tmp : constant Elmt_Ptr := Tab.Get_First (Tab.Instance (T));
256 begin
257 if Tmp = null then
258 return Key_Option'(Present => False);
259 else
260 return Key_Option'(Present => True, K => Tmp.all.K);
261 end if;
262 end Get_First_Key;
263
264 -------------
265 -- Get_Key --
266 -------------
267
268 function Get_Key (E : Elmt_Ptr) return Key is
269 begin
270 return E.K;
271 end Get_Key;
272
273 --------------
274 -- Get_Next --
275 --------------
276
277 function Get_Next (T : Instance) return Element is
278 Tmp : constant Elmt_Ptr := Tab.Get_Next (Tab.Instance (T));
279 begin
280 if Tmp = null then
281 return No_Element;
282 else
283 return Tmp.E;
284 end if;
285 end Get_Next;
286
287 ------------------
288 -- Get_Next_Key --
289 ------------------
290
291 function Get_Next_Key (T : Instance) return Key_Option is
292 Tmp : constant Elmt_Ptr := Tab.Get_Next (Tab.Instance (T));
293 begin
294 if Tmp = null then
295 return Key_Option'(Present => False);
296 else
297 return Key_Option'(Present => True, K => Tmp.all.K);
298 end if;
299 end Get_Next_Key;
300
301 ----------
302 -- Next --
303 ----------
304
305 function Next (E : Elmt_Ptr) return Elmt_Ptr is
306 begin
307 return E.Next;
308 end Next;
309
310 ------------
311 -- Remove --
312 ------------
313
314 procedure Remove (T : Instance; K : Key) is
315 Tmp : Elmt_Ptr;
316
317 begin
318 Tmp := Tab.Get (Tab.Instance (T), K);
319
320 if Tmp /= null then
321 Tab.Remove (Tab.Instance (T), K);
322 Free (Tmp);
323 end if;
324 end Remove;
325
326 -----------
327 -- Reset --
328 -----------
329
330 procedure Reset (T : in out Instance) is
331 E1, E2 : Elmt_Ptr;
332
333 begin
334 E1 := Tab.Get_First (Tab.Instance (T));
335 while E1 /= null loop
336 E2 := Tab.Get_Next (Tab.Instance (T));
337 Free (E1);
338 E1 := E2;
339 end loop;
340
341 Tab.Reset (Tab.Instance (T));
342 end Reset;
343
344 ---------
345 -- Set --
346 ---------
347
348 procedure Set (T : in out Instance; K : Key; E : Element) is
349 Tmp : constant Elmt_Ptr := Tab.Get (Tab.Instance (T), K);
350 begin
351 if Tmp = null then
352 Tab.Set (Tab.Instance (T), new Element_Wrapper'(K, E, null));
353 else
354 Tmp.E := E;
355 end if;
356 end Set;
357
358 --------------
359 -- Set_Next --
360 --------------
361
362 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
363 begin
364 E.Next := Next;
365 end Set_Next;
366
367 end Simple_HTable;
368
369 end GNAT.Dynamic_HTables;