File : a-chtgbk.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT LIBRARY COMPONENTS --
4 -- --
5 -- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_KEYS --
6 -- --
7 -- B o d y --
8 -- --
9 -- Copyright (C) 2004-2015, Free Software Foundation, Inc. --
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 -- This unit was originally developed by Matthew J Heaney. --
28 ------------------------------------------------------------------------------
29
30 package body Ada.Containers.Hash_Tables.Generic_Bounded_Keys is
31
32 pragma Warnings (Off, "variable ""Busy*"" is not referenced");
33 pragma Warnings (Off, "variable ""Lock*"" is not referenced");
34 -- See comment in Ada.Containers.Helpers
35
36 -----------------------------
37 -- Checked_Equivalent_Keys --
38 -----------------------------
39
40 function Checked_Equivalent_Keys
41 (HT : aliased in out Hash_Table_Type'Class;
42 Key : Key_Type;
43 Node : Count_Type) return Boolean
44 is
45 Lock : With_Lock (HT.TC'Unrestricted_Access);
46 begin
47 return Equivalent_Keys (Key, HT.Nodes (Node));
48 end Checked_Equivalent_Keys;
49
50 -------------------
51 -- Checked_Index --
52 -------------------
53
54 function Checked_Index
55 (HT : aliased in out Hash_Table_Type'Class;
56 Key : Key_Type) return Hash_Type
57 is
58 Lock : With_Lock (HT.TC'Unrestricted_Access);
59 begin
60 return HT.Buckets'First + Hash (Key) mod HT.Buckets'Length;
61 end Checked_Index;
62
63 --------------------------
64 -- Delete_Key_Sans_Free --
65 --------------------------
66
67 procedure Delete_Key_Sans_Free
68 (HT : in out Hash_Table_Type'Class;
69 Key : Key_Type;
70 X : out Count_Type)
71 is
72 Indx : Hash_Type;
73 Prev : Count_Type;
74
75 begin
76 if HT.Length = 0 then
77 X := 0;
78 return;
79 end if;
80
81 -- Per AI05-0022, the container implementation is required to detect
82 -- element tampering by a generic actual subprogram.
83
84 TC_Check (HT.TC);
85
86 Indx := Checked_Index (HT, Key);
87 X := HT.Buckets (Indx);
88
89 if X = 0 then
90 return;
91 end if;
92
93 if Checked_Equivalent_Keys (HT, Key, X) then
94 TC_Check (HT.TC);
95 HT.Buckets (Indx) := Next (HT.Nodes (X));
96 HT.Length := HT.Length - 1;
97 return;
98 end if;
99
100 loop
101 Prev := X;
102 X := Next (HT.Nodes (Prev));
103
104 if X = 0 then
105 return;
106 end if;
107
108 if Checked_Equivalent_Keys (HT, Key, X) then
109 TC_Check (HT.TC);
110 Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (X)));
111 HT.Length := HT.Length - 1;
112 return;
113 end if;
114 end loop;
115 end Delete_Key_Sans_Free;
116
117 ----------
118 -- Find --
119 ----------
120
121 function Find
122 (HT : Hash_Table_Type'Class;
123 Key : Key_Type) return Count_Type
124 is
125 Indx : Hash_Type;
126 Node : Count_Type;
127
128 begin
129 if HT.Length = 0 then
130 return 0;
131 end if;
132
133 Indx := Checked_Index (HT'Unrestricted_Access.all, Key);
134
135 Node := HT.Buckets (Indx);
136 while Node /= 0 loop
137 if Checked_Equivalent_Keys
138 (HT'Unrestricted_Access.all, Key, Node)
139 then
140 return Node;
141 end if;
142 Node := Next (HT.Nodes (Node));
143 end loop;
144
145 return 0;
146 end Find;
147
148 --------------------------------
149 -- Generic_Conditional_Insert --
150 --------------------------------
151
152 procedure Generic_Conditional_Insert
153 (HT : in out Hash_Table_Type'Class;
154 Key : Key_Type;
155 Node : out Count_Type;
156 Inserted : out Boolean)
157 is
158 Indx : Hash_Type;
159
160 begin
161 -- Per AI05-0022, the container implementation is required to detect
162 -- element tampering by a generic actual subprogram.
163
164 TC_Check (HT.TC);
165
166 Indx := Checked_Index (HT, Key);
167 Node := HT.Buckets (Indx);
168
169 if Node = 0 then
170 if Checks and then HT.Length = HT.Capacity then
171 raise Capacity_Error with "no more capacity for insertion";
172 end if;
173
174 Node := New_Node;
175 Set_Next (HT.Nodes (Node), Next => 0);
176
177 Inserted := True;
178
179 HT.Buckets (Indx) := Node;
180 HT.Length := HT.Length + 1;
181
182 return;
183 end if;
184
185 loop
186 if Checked_Equivalent_Keys (HT, Key, Node) then
187 Inserted := False;
188 return;
189 end if;
190
191 Node := Next (HT.Nodes (Node));
192
193 exit when Node = 0;
194 end loop;
195
196 if Checks and then HT.Length = HT.Capacity then
197 raise Capacity_Error with "no more capacity for insertion";
198 end if;
199
200 Node := New_Node;
201 Set_Next (HT.Nodes (Node), Next => HT.Buckets (Indx));
202
203 Inserted := True;
204
205 HT.Buckets (Indx) := Node;
206 HT.Length := HT.Length + 1;
207 end Generic_Conditional_Insert;
208
209 -----------------------------
210 -- Generic_Replace_Element --
211 -----------------------------
212
213 procedure Generic_Replace_Element
214 (HT : in out Hash_Table_Type'Class;
215 Node : Count_Type;
216 Key : Key_Type)
217 is
218 pragma Assert (HT.Length > 0);
219 pragma Assert (Node /= 0);
220
221 BB : Buckets_Type renames HT.Buckets;
222 NN : Nodes_Type renames HT.Nodes;
223
224 Old_Indx : Hash_Type;
225 New_Indx : constant Hash_Type := Checked_Index (HT, Key);
226
227 New_Bucket : Count_Type renames BB (New_Indx);
228 N, M : Count_Type;
229
230 begin
231 -- Per AI05-0022, the container implementation is required to detect
232 -- element tampering by a generic actual subprogram.
233
234 -- The following block appears to be vestigial -- this should be done
235 -- using Checked_Index instead. Also, we might have to move the actual
236 -- tampering checks to the top of the subprogram, in order to prevent
237 -- infinite recursion when calling Hash. (This is similar to how Insert
238 -- and Delete are implemented.) This implies that we will have to defer
239 -- the computation of New_Index until after the tampering check. ???
240
241 declare
242 Lock : With_Lock (HT.TC'Unrestricted_Access);
243 begin
244 Old_Indx := HT.Buckets'First + Hash (NN (Node)) mod HT.Buckets'Length;
245 end;
246
247 -- Replace_Element is allowed to change a node's key to Key
248 -- (generic formal operation Assign provides the mechanism), but
249 -- only if Key is not already in the hash table. (In a unique-key
250 -- hash table as this one, a key is mapped to exactly one node.)
251
252 if Checked_Equivalent_Keys (HT, Key, Node) then
253 TE_Check (HT.TC);
254
255 -- The new Key value is mapped to this same Node, so Node
256 -- stays in the same bucket.
257
258 Assign (NN (Node), Key);
259 return;
260 end if;
261
262 -- Key is not equivalent to Node, so we now have to determine if it's
263 -- equivalent to some other node in the hash table. This is the case
264 -- irrespective of whether Key is in the same or a different bucket from
265 -- Node.
266
267 N := New_Bucket;
268 while N /= 0 loop
269 if Checks and then Checked_Equivalent_Keys (HT, Key, N) then
270 pragma Assert (N /= Node);
271 raise Program_Error with
272 "attempt to replace existing element";
273 end if;
274
275 N := Next (NN (N));
276 end loop;
277
278 -- We have determined that Key is not already in the hash table, so
279 -- the change is tentatively allowed. We now perform the standard
280 -- checks to determine whether the hash table is locked (because you
281 -- cannot change an element while it's in use by Query_Element or
282 -- Update_Element), or if the container is busy (because moving a
283 -- node to a different bucket would interfere with iteration).
284
285 if Old_Indx = New_Indx then
286 -- The node is already in the bucket implied by Key. In this case
287 -- we merely change its value without moving it.
288
289 TE_Check (HT.TC);
290
291 Assign (NN (Node), Key);
292 return;
293 end if;
294
295 -- The node is a bucket different from the bucket implied by Key
296
297 TC_Check (HT.TC);
298
299 -- Do the assignment first, before moving the node, so that if Assign
300 -- propagates an exception, then the hash table will not have been
301 -- modified (except for any possible side-effect Assign had on Node).
302
303 Assign (NN (Node), Key);
304
305 -- Now we can safely remove the node from its current bucket
306
307 N := BB (Old_Indx); -- get value of first node in old bucket
308 pragma Assert (N /= 0);
309
310 if N = Node then -- node is first node in its bucket
311 BB (Old_Indx) := Next (NN (Node));
312
313 else
314 pragma Assert (HT.Length > 1);
315
316 loop
317 M := Next (NN (N));
318 pragma Assert (M /= 0);
319
320 if M = Node then
321 Set_Next (NN (N), Next => Next (NN (Node)));
322 exit;
323 end if;
324
325 N := M;
326 end loop;
327 end if;
328
329 -- Now we link the node into its new bucket (corresponding to Key)
330
331 Set_Next (NN (Node), Next => New_Bucket);
332 New_Bucket := Node;
333 end Generic_Replace_Element;
334
335 -----------
336 -- Index --
337 -----------
338
339 function Index
340 (HT : Hash_Table_Type'Class;
341 Key : Key_Type) return Hash_Type is
342 begin
343 return HT.Buckets'First + Hash (Key) mod HT.Buckets'Length;
344 end Index;
345
346 end Ada.Containers.Hash_Tables.Generic_Bounded_Keys;