|
111
|
1 ------------------------------------------------------------------------------
|
|
|
2 -- --
|
|
|
3 -- GNAT RUN-TIME COMPONENTS --
|
|
|
4 -- --
|
|
|
5 -- S Y S T E M . H T A B L E --
|
|
|
6 -- --
|
|
|
7 -- B o d y --
|
|
|
8 -- --
|
|
131
|
9 -- Copyright (C) 1995-2018, AdaCore --
|
|
111
|
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 pragma Compiler_Unit_Warning;
|
|
|
33
|
|
|
34 with Ada.Unchecked_Deallocation;
|
|
|
35 with System.String_Hash;
|
|
|
36
|
|
|
37 package body System.HTable is
|
|
|
38
|
|
|
39 -------------------
|
|
|
40 -- Static_HTable --
|
|
|
41 -------------------
|
|
|
42
|
|
|
43 package body Static_HTable is
|
|
|
44
|
|
|
45 Table : array (Header_Num) of Elmt_Ptr;
|
|
|
46
|
|
|
47 Iterator_Index : Header_Num;
|
|
|
48 Iterator_Ptr : Elmt_Ptr;
|
|
|
49 Iterator_Started : Boolean := False;
|
|
|
50
|
|
|
51 function Get_Non_Null return Elmt_Ptr;
|
|
|
52 -- Returns Null_Ptr if Iterator_Started is false or the Table is empty.
|
|
|
53 -- Returns Iterator_Ptr if non null, or the next non null element in
|
|
|
54 -- table if any.
|
|
|
55
|
|
|
56 ---------
|
|
|
57 -- Get --
|
|
|
58 ---------
|
|
|
59
|
|
|
60 function Get (K : Key) return Elmt_Ptr is
|
|
|
61 Elmt : Elmt_Ptr;
|
|
|
62
|
|
|
63 begin
|
|
|
64 Elmt := Table (Hash (K));
|
|
|
65 loop
|
|
|
66 if Elmt = Null_Ptr then
|
|
|
67 return Null_Ptr;
|
|
|
68
|
|
|
69 elsif Equal (Get_Key (Elmt), K) then
|
|
|
70 return Elmt;
|
|
|
71
|
|
|
72 else
|
|
|
73 Elmt := Next (Elmt);
|
|
|
74 end if;
|
|
|
75 end loop;
|
|
|
76 end Get;
|
|
|
77
|
|
|
78 ---------------
|
|
|
79 -- Get_First --
|
|
|
80 ---------------
|
|
|
81
|
|
|
82 function Get_First return Elmt_Ptr is
|
|
|
83 begin
|
|
|
84 Iterator_Started := True;
|
|
|
85 Iterator_Index := Table'First;
|
|
|
86 Iterator_Ptr := Table (Iterator_Index);
|
|
|
87 return Get_Non_Null;
|
|
|
88 end Get_First;
|
|
|
89
|
|
|
90 --------------
|
|
|
91 -- Get_Next --
|
|
|
92 --------------
|
|
|
93
|
|
|
94 function Get_Next return Elmt_Ptr is
|
|
|
95 begin
|
|
|
96 if not Iterator_Started then
|
|
|
97 return Null_Ptr;
|
|
|
98 else
|
|
|
99 Iterator_Ptr := Next (Iterator_Ptr);
|
|
|
100 return Get_Non_Null;
|
|
|
101 end if;
|
|
|
102 end Get_Next;
|
|
|
103
|
|
|
104 ------------------
|
|
|
105 -- Get_Non_Null --
|
|
|
106 ------------------
|
|
|
107
|
|
|
108 function Get_Non_Null return Elmt_Ptr is
|
|
|
109 begin
|
|
|
110 while Iterator_Ptr = Null_Ptr loop
|
|
|
111 if Iterator_Index = Table'Last then
|
|
|
112 Iterator_Started := False;
|
|
|
113 return Null_Ptr;
|
|
|
114 end if;
|
|
|
115
|
|
|
116 Iterator_Index := Iterator_Index + 1;
|
|
|
117 Iterator_Ptr := Table (Iterator_Index);
|
|
|
118 end loop;
|
|
|
119
|
|
|
120 return Iterator_Ptr;
|
|
|
121 end Get_Non_Null;
|
|
|
122
|
|
|
123 -------------
|
|
|
124 -- Present --
|
|
|
125 -------------
|
|
|
126
|
|
|
127 function Present (K : Key) return Boolean is
|
|
|
128 begin
|
|
|
129 return Get (K) /= Null_Ptr;
|
|
|
130 end Present;
|
|
|
131
|
|
|
132 ------------
|
|
|
133 -- Remove --
|
|
|
134 ------------
|
|
|
135
|
|
|
136 procedure Remove (K : Key) is
|
|
|
137 Index : constant Header_Num := Hash (K);
|
|
|
138 Elmt : Elmt_Ptr;
|
|
|
139 Next_Elmt : Elmt_Ptr;
|
|
|
140
|
|
|
141 begin
|
|
|
142 Elmt := Table (Index);
|
|
|
143
|
|
|
144 if Elmt = Null_Ptr then
|
|
|
145 return;
|
|
|
146
|
|
|
147 elsif Equal (Get_Key (Elmt), K) then
|
|
|
148 Table (Index) := Next (Elmt);
|
|
|
149
|
|
|
150 else
|
|
|
151 loop
|
|
|
152 Next_Elmt := Next (Elmt);
|
|
|
153
|
|
|
154 if Next_Elmt = Null_Ptr then
|
|
|
155 return;
|
|
|
156
|
|
|
157 elsif Equal (Get_Key (Next_Elmt), K) then
|
|
|
158 Set_Next (Elmt, Next (Next_Elmt));
|
|
|
159 return;
|
|
|
160
|
|
|
161 else
|
|
|
162 Elmt := Next_Elmt;
|
|
|
163 end if;
|
|
|
164 end loop;
|
|
|
165 end if;
|
|
|
166 end Remove;
|
|
|
167
|
|
|
168 -----------
|
|
|
169 -- Reset --
|
|
|
170 -----------
|
|
|
171
|
|
|
172 procedure Reset is
|
|
|
173 begin
|
|
|
174 -- Use an aggregate for efficiency reasons
|
|
|
175
|
|
|
176 Table := (others => Null_Ptr);
|
|
|
177 end Reset;
|
|
|
178
|
|
|
179 ---------
|
|
|
180 -- Set --
|
|
|
181 ---------
|
|
|
182
|
|
|
183 procedure Set (E : Elmt_Ptr) is
|
|
|
184 Index : Header_Num;
|
|
|
185 begin
|
|
|
186 Index := Hash (Get_Key (E));
|
|
|
187 Set_Next (E, Table (Index));
|
|
|
188 Table (Index) := E;
|
|
|
189 end Set;
|
|
|
190
|
|
|
191 ------------------------
|
|
|
192 -- Set_If_Not_Present --
|
|
|
193 ------------------------
|
|
|
194
|
|
|
195 function Set_If_Not_Present (E : Elmt_Ptr) return Boolean is
|
|
|
196 K : Key renames Get_Key (E);
|
|
|
197 -- Note that it is important to use a renaming here rather than
|
|
|
198 -- define a constant initialized by the call, because the latter
|
|
|
199 -- construct runs into bootstrap problems with earlier versions
|
|
|
200 -- of the GNAT compiler.
|
|
|
201
|
|
|
202 Index : constant Header_Num := Hash (K);
|
|
|
203 Elmt : Elmt_Ptr;
|
|
|
204
|
|
|
205 begin
|
|
|
206 Elmt := Table (Index);
|
|
|
207 loop
|
|
|
208 if Elmt = Null_Ptr then
|
|
|
209 Set_Next (E, Table (Index));
|
|
|
210 Table (Index) := E;
|
|
|
211 return True;
|
|
|
212
|
|
|
213 elsif Equal (Get_Key (Elmt), K) then
|
|
|
214 return False;
|
|
|
215
|
|
|
216 else
|
|
|
217 Elmt := Next (Elmt);
|
|
|
218 end if;
|
|
|
219 end loop;
|
|
|
220 end Set_If_Not_Present;
|
|
|
221
|
|
|
222 end Static_HTable;
|
|
|
223
|
|
|
224 -------------------
|
|
|
225 -- Simple_HTable --
|
|
|
226 -------------------
|
|
|
227
|
|
|
228 package body Simple_HTable is
|
|
|
229
|
|
|
230 type Element_Wrapper;
|
|
|
231 type Elmt_Ptr is access all Element_Wrapper;
|
|
|
232 type Element_Wrapper is record
|
|
|
233 K : Key;
|
|
|
234 E : Element;
|
|
|
235 Next : Elmt_Ptr;
|
|
|
236 end record;
|
|
|
237
|
|
|
238 procedure Free is new
|
|
|
239 Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr);
|
|
|
240
|
|
|
241 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr);
|
|
|
242 function Next (E : Elmt_Ptr) return Elmt_Ptr;
|
|
|
243 function Get_Key (E : Elmt_Ptr) return Key;
|
|
|
244
|
|
|
245 package Tab is new Static_HTable (
|
|
|
246 Header_Num => Header_Num,
|
|
|
247 Element => Element_Wrapper,
|
|
|
248 Elmt_Ptr => Elmt_Ptr,
|
|
|
249 Null_Ptr => null,
|
|
|
250 Set_Next => Set_Next,
|
|
|
251 Next => Next,
|
|
|
252 Key => Key,
|
|
|
253 Get_Key => Get_Key,
|
|
|
254 Hash => Hash,
|
|
|
255 Equal => Equal);
|
|
|
256
|
|
|
257 ---------
|
|
|
258 -- Get --
|
|
|
259 ---------
|
|
|
260
|
|
|
261 function Get (K : Key) return Element is
|
|
|
262 Tmp : constant Elmt_Ptr := Tab.Get (K);
|
|
|
263 begin
|
|
|
264 if Tmp = null then
|
|
|
265 return No_Element;
|
|
|
266 else
|
|
|
267 return Tmp.E;
|
|
|
268 end if;
|
|
|
269 end Get;
|
|
|
270
|
|
|
271 ---------------
|
|
|
272 -- Get_First --
|
|
|
273 ---------------
|
|
|
274
|
|
|
275 function Get_First return Element is
|
|
|
276 Tmp : constant Elmt_Ptr := Tab.Get_First;
|
|
|
277 begin
|
|
|
278 if Tmp = null then
|
|
|
279 return No_Element;
|
|
|
280 else
|
|
|
281 return Tmp.E;
|
|
|
282 end if;
|
|
|
283 end Get_First;
|
|
|
284
|
|
|
285 procedure Get_First (K : in out Key; E : out Element) is
|
|
|
286 Tmp : constant Elmt_Ptr := Tab.Get_First;
|
|
|
287 begin
|
|
|
288 if Tmp = null then
|
|
|
289 E := No_Element;
|
|
|
290 else
|
|
|
291 K := Tmp.K;
|
|
|
292 E := Tmp.E;
|
|
|
293 end if;
|
|
|
294 end Get_First;
|
|
|
295
|
|
|
296 -------------
|
|
|
297 -- Get_Key --
|
|
|
298 -------------
|
|
|
299
|
|
|
300 function Get_Key (E : Elmt_Ptr) return Key is
|
|
|
301 begin
|
|
|
302 return E.K;
|
|
|
303 end Get_Key;
|
|
|
304
|
|
|
305 --------------
|
|
|
306 -- Get_Next --
|
|
|
307 --------------
|
|
|
308
|
|
|
309 function Get_Next return Element is
|
|
|
310 Tmp : constant Elmt_Ptr := Tab.Get_Next;
|
|
|
311 begin
|
|
|
312 if Tmp = null then
|
|
|
313 return No_Element;
|
|
|
314 else
|
|
|
315 return Tmp.E;
|
|
|
316 end if;
|
|
|
317 end Get_Next;
|
|
|
318
|
|
|
319 procedure Get_Next (K : in out Key; E : out Element) is
|
|
|
320 Tmp : constant Elmt_Ptr := Tab.Get_Next;
|
|
|
321 begin
|
|
|
322 if Tmp = null then
|
|
|
323 E := No_Element;
|
|
|
324 else
|
|
|
325 K := Tmp.K;
|
|
|
326 E := Tmp.E;
|
|
|
327 end if;
|
|
|
328 end Get_Next;
|
|
|
329
|
|
|
330 ----------
|
|
|
331 -- Next --
|
|
|
332 ----------
|
|
|
333
|
|
|
334 function Next (E : Elmt_Ptr) return Elmt_Ptr is
|
|
|
335 begin
|
|
|
336 return E.Next;
|
|
|
337 end Next;
|
|
|
338
|
|
|
339 ------------
|
|
|
340 -- Remove --
|
|
|
341 ------------
|
|
|
342
|
|
|
343 procedure Remove (K : Key) is
|
|
|
344 Tmp : Elmt_Ptr;
|
|
|
345
|
|
|
346 begin
|
|
|
347 Tmp := Tab.Get (K);
|
|
|
348
|
|
|
349 if Tmp /= null then
|
|
|
350 Tab.Remove (K);
|
|
|
351 Free (Tmp);
|
|
|
352 end if;
|
|
|
353 end Remove;
|
|
|
354
|
|
|
355 -----------
|
|
|
356 -- Reset --
|
|
|
357 -----------
|
|
|
358
|
|
|
359 procedure Reset is
|
|
|
360 E1, E2 : Elmt_Ptr;
|
|
|
361
|
|
|
362 begin
|
|
|
363 E1 := Tab.Get_First;
|
|
|
364 while E1 /= null loop
|
|
|
365 E2 := Tab.Get_Next;
|
|
|
366 Free (E1);
|
|
|
367 E1 := E2;
|
|
|
368 end loop;
|
|
|
369
|
|
|
370 Tab.Reset;
|
|
|
371 end Reset;
|
|
|
372
|
|
|
373 ---------
|
|
|
374 -- Set --
|
|
|
375 ---------
|
|
|
376
|
|
|
377 procedure Set (K : Key; E : Element) is
|
|
|
378 Tmp : constant Elmt_Ptr := Tab.Get (K);
|
|
|
379 begin
|
|
|
380 if Tmp = null then
|
|
|
381 Tab.Set (new Element_Wrapper'(K, E, null));
|
|
|
382 else
|
|
|
383 Tmp.E := E;
|
|
|
384 end if;
|
|
|
385 end Set;
|
|
|
386
|
|
|
387 --------------
|
|
|
388 -- Set_Next --
|
|
|
389 --------------
|
|
|
390
|
|
|
391 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
|
|
|
392 begin
|
|
|
393 E.Next := Next;
|
|
|
394 end Set_Next;
|
|
|
395 end Simple_HTable;
|
|
|
396
|
|
|
397 ----------
|
|
|
398 -- Hash --
|
|
|
399 ----------
|
|
|
400
|
|
|
401 function Hash (Key : String) return Header_Num is
|
|
|
402 type Uns is mod 2 ** 32;
|
|
|
403
|
|
|
404 function Hash_Fun is
|
|
|
405 new System.String_Hash.Hash (Character, String, Uns);
|
|
|
406
|
|
|
407 begin
|
|
|
408 return Header_Num'First +
|
|
|
409 Header_Num'Base (Hash_Fun (Key) mod Header_Num'Range_Length);
|
|
|
410 end Hash;
|
|
|
411
|
|
|
412 end System.HTable;
|
