File : s-htable.adb
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 -- --
9 -- Copyright (C) 1995-2016, 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 -- --
19 -- --
20 -- --
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 for J in Table'Range loop
175 Table (J) := Null_Ptr;
176 end loop;
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;