]>
Commit | Line | Data |
---|---|---|
fbf5a39b AC |
1 | ------------------------------------------------------------------------------ |
2 | -- -- | |
3084fecd | 3 | -- GNAT RUN-TIME COMPONENTS -- |
fbf5a39b AC |
4 | -- -- |
5 | -- S Y S T E M . H T A B L E -- | |
6 | -- -- | |
7 | -- B o d y -- | |
8 | -- -- | |
4b490c1e | 9 | -- Copyright (C) 1995-2020, AdaCore -- |
fbf5a39b AC |
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- -- | |
607d0635 | 13 | -- ware Foundation; either version 3, or (at your option) any later ver- -- |
fbf5a39b AC |
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 -- | |
607d0635 AC |
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/>. -- | |
fbf5a39b AC |
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 | ||
e917e3b8 | 32 | pragma Compiler_Unit_Warning; |
2d9ea47f | 33 | |
fbf5a39b | 34 | with Ada.Unchecked_Deallocation; |
d88a51b1 | 35 | with System.String_Hash; |
fbf5a39b AC |
36 | |
37 | package body System.HTable is | |
38 | ||
15ce9ca2 AC |
39 | ------------------- |
40 | -- Static_HTable -- | |
41 | ------------------- | |
fbf5a39b AC |
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; | |
bfc8aa81 RD |
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. | |
fbf5a39b AC |
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)); | |
fbf5a39b AC |
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; | |
5067f3a0 PMR |
85 | Iterator_Index := Table'First; |
86 | Iterator_Ptr := Table (Iterator_Index); | |
fbf5a39b AC |
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; | |
1bd84c71 AC |
98 | else |
99 | Iterator_Ptr := Next (Iterator_Ptr); | |
100 | return Get_Non_Null; | |
fbf5a39b | 101 | end if; |
fbf5a39b AC |
102 | end Get_Next; |
103 | ||
104 | ------------------ | |
105 | -- Get_Non_Null -- | |
106 | ------------------ | |
107 | ||
108 | function Get_Non_Null return Elmt_Ptr is | |
109 | begin | |
0f1a6a0b | 110 | while Iterator_Ptr = Null_Ptr loop |
fbf5a39b AC |
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 | ||
f7bb41af AC |
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 | ||
fbf5a39b AC |
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 | |
c8307596 | 152 | Next_Elmt := Next (Elmt); |
fbf5a39b AC |
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 | |
9c5719f6 | 174 | -- Use an aggregate for efficiency reasons |
333e4f86 AC |
175 | |
176 | Table := (others => Null_Ptr); | |
fbf5a39b AC |
177 | end Reset; |
178 | ||
179 | --------- | |
180 | -- Set -- | |
181 | --------- | |
182 | ||
183 | procedure Set (E : Elmt_Ptr) is | |
184 | Index : Header_Num; | |
fbf5a39b AC |
185 | begin |
186 | Index := Hash (Get_Key (E)); | |
187 | Set_Next (E, Table (Index)); | |
188 | Table (Index) := E; | |
189 | end Set; | |
190 | ||
f7bb41af AC |
191 | ------------------------ |
192 | -- Set_If_Not_Present -- | |
193 | ------------------------ | |
194 | ||
195 | function Set_If_Not_Present (E : Elmt_Ptr) return Boolean is | |
83de674b AC |
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 | ||
f7bb41af | 202 | Index : constant Header_Num := Hash (K); |
2c17ca0a | 203 | Elmt : Elmt_Ptr; |
f7bb41af AC |
204 | |
205 | begin | |
2c17ca0a | 206 | Elmt := Table (Index); |
f7bb41af AC |
207 | loop |
208 | if Elmt = Null_Ptr then | |
209 | Set_Next (E, Table (Index)); | |
210 | Table (Index) := E; | |
f7bb41af AC |
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 | ||
fbf5a39b AC |
222 | end Static_HTable; |
223 | ||
0fb2ea01 AC |
224 | ------------------- |
225 | -- Simple_HTable -- | |
226 | ------------------- | |
fbf5a39b AC |
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 | ||
497a660d | 261 | function Get (K : Key) return Element is |
fbf5a39b | 262 | Tmp : constant Elmt_Ptr := Tab.Get (K); |
fbf5a39b AC |
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; | |
fbf5a39b AC |
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 | ||
c159409f AC |
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 | ||
fbf5a39b AC |
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; | |
fbf5a39b AC |
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 | ||
c159409f AC |
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 | ||
fbf5a39b AC |
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); | |
fbf5a39b AC |
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 | |
fbf5a39b AC |
402 | type Uns is mod 2 ** 32; |
403 | ||
d88a51b1 AC |
404 | function Hash_Fun is |
405 | new System.String_Hash.Hash (Character, String, Uns); | |
fbf5a39b AC |
406 | |
407 | begin | |
fbf5a39b | 408 | return Header_Num'First + |
d88a51b1 | 409 | Header_Num'Base (Hash_Fun (Key) mod Header_Num'Range_Length); |
fbf5a39b AC |
410 | end Hash; |
411 | ||
412 | end System.HTable; |