File : a-chtgke.adb
1 ------------------------------------------------------------------------------
2 -- --
3 -- GNAT LIBRARY COMPONENTS --
4 -- --
5 -- ADA.CONTAINERS.HASH_TABLES.GENERIC_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_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;
42 Key : Key_Type;
43 Node : Node_Access) return Boolean
44 is
45 Lock : With_Lock (HT.TC'Unrestricted_Access);
46 begin
47 return Equivalent_Keys (Key, 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;
56 Key : Key_Type) return Hash_Type
57 is
58 Lock : With_Lock (HT.TC'Unrestricted_Access);
59 begin
60 return 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;
69 Key : Key_Type;
70 X : out Node_Access)
71 is
72 Indx : Hash_Type;
73 Prev : Node_Access;
74
75 begin
76 if HT.Length = 0 then
77 X := null;
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 = null 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 (X);
96 HT.Length := HT.Length - 1;
97 return;
98 end if;
99
100 loop
101 Prev := X;
102 X := Next (Prev);
103
104 if X = null then
105 return;
106 end if;
107
108 if Checked_Equivalent_Keys (HT, Key, X) then
109 TC_Check (HT.TC);
110 Set_Next (Node => Prev, Next => Next (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 : aliased in out Hash_Table_Type;
123 Key : Key_Type) return Node_Access
124 is
125 Indx : Hash_Type;
126 Node : Node_Access;
127
128 begin
129 if HT.Length = 0 then
130 return null;
131 end if;
132
133 Indx := Checked_Index (HT, Key);
134
135 Node := HT.Buckets (Indx);
136 while Node /= null loop
137 if Checked_Equivalent_Keys (HT, Key, Node) then
138 return Node;
139 end if;
140 Node := Next (Node);
141 end loop;
142
143 return null;
144 end Find;
145
146 --------------------------------
147 -- Generic_Conditional_Insert --
148 --------------------------------
149
150 procedure Generic_Conditional_Insert
151 (HT : in out Hash_Table_Type;
152 Key : Key_Type;
153 Node : out Node_Access;
154 Inserted : out Boolean)
155 is
156 Indx : Hash_Type;
157
158 begin
159 -- Per AI05-0022, the container implementation is required to detect
160 -- element tampering by a generic actual subprogram.
161
162 TC_Check (HT.TC);
163
164 Indx := Checked_Index (HT, Key);
165 Node := HT.Buckets (Indx);
166
167 if Node = null then
168 if Checks and then HT.Length = Count_Type'Last then
169 raise Constraint_Error;
170 end if;
171
172 Node := New_Node (Next => null);
173 Inserted := True;
174
175 HT.Buckets (Indx) := Node;
176 HT.Length := HT.Length + 1;
177
178 return;
179 end if;
180
181 loop
182 if Checked_Equivalent_Keys (HT, Key, Node) then
183 Inserted := False;
184 return;
185 end if;
186
187 Node := Next (Node);
188
189 exit when Node = null;
190 end loop;
191
192 if Checks and then HT.Length = Count_Type'Last then
193 raise Constraint_Error;
194 end if;
195
196 Node := New_Node (Next => HT.Buckets (Indx));
197 Inserted := True;
198
199 HT.Buckets (Indx) := Node;
200 HT.Length := HT.Length + 1;
201 end Generic_Conditional_Insert;
202
203 -----------------------------
204 -- Generic_Replace_Element --
205 -----------------------------
206
207 procedure Generic_Replace_Element
208 (HT : in out Hash_Table_Type;
209 Node : Node_Access;
210 Key : Key_Type)
211 is
212 pragma Assert (HT.Length > 0);
213 pragma Assert (Node /= null);
214
215 Old_Indx : Hash_Type;
216 New_Indx : constant Hash_Type := Checked_Index (HT, Key);
217
218 New_Bucket : Node_Access renames HT.Buckets (New_Indx);
219 N, M : Node_Access;
220
221 begin
222 -- Per AI05-0022, the container implementation is required to detect
223 -- element tampering by a generic actual subprogram.
224
225 declare
226 Lock : With_Lock (HT.TC'Unrestricted_Access);
227 begin
228 Old_Indx := Hash (Node) mod HT.Buckets'Length;
229 end;
230
231 if Checked_Equivalent_Keys (HT, Key, Node) then
232 TE_Check (HT.TC);
233
234 -- We can change a node's key to Key (that's what Assign is for), but
235 -- only if Key is not already in the hash table. (In a unique-key
236 -- hash table as this one a key is mapped to exactly one node only.)
237 -- The exception is when Key is mapped to Node, in which case the
238 -- change is allowed.
239
240 Assign (Node, Key);
241 return;
242 end if;
243
244 -- Key is not equivalent to Node, so we now have to determine if it's
245 -- equivalent to some other node in the hash table. This is the case
246 -- irrespective of whether Key is in the same or a different bucket from
247 -- Node.
248
249 N := New_Bucket;
250 while N /= null loop
251 if Checks and then Checked_Equivalent_Keys (HT, Key, N) then
252 pragma Assert (N /= Node);
253 raise Program_Error with
254 "attempt to replace existing element";
255 end if;
256
257 N := Next (N);
258 end loop;
259
260 -- We have determined that Key is not already in the hash table, so
261 -- the change is tentatively allowed. We now perform the standard
262 -- checks to determine whether the hash table is locked (because you
263 -- cannot change an element while it's in use by Query_Element or
264 -- Update_Element), or if the container is busy (because moving a
265 -- node to a different bucket would interfere with iteration).
266
267 if Old_Indx = New_Indx then
268 -- The node is already in the bucket implied by Key. In this case
269 -- we merely change its value without moving it.
270
271 TE_Check (HT.TC);
272
273 Assign (Node, Key);
274 return;
275 end if;
276
277 -- The node is a bucket different from the bucket implied by Key
278
279 TC_Check (HT.TC);
280
281 -- Do the assignment first, before moving the node, so that if Assign
282 -- propagates an exception, then the hash table will not have been
283 -- modified (except for any possible side-effect Assign had on Node).
284
285 Assign (Node, Key);
286
287 -- Now we can safely remove the node from its current bucket
288
289 N := HT.Buckets (Old_Indx);
290 pragma Assert (N /= null);
291
292 if N = Node then
293 HT.Buckets (Old_Indx) := Next (Node);
294
295 else
296 pragma Assert (HT.Length > 1);
297
298 loop
299 M := Next (N);
300 pragma Assert (M /= null);
301
302 if M = Node then
303 Set_Next (Node => N, Next => Next (Node));
304 exit;
305 end if;
306
307 N := M;
308 end loop;
309 end if;
310
311 -- Now we link the node into its new bucket (corresponding to Key)
312
313 Set_Next (Node => Node, Next => New_Bucket);
314 New_Bucket := Node;
315 end Generic_Replace_Element;
316
317 -----------
318 -- Index --
319 -----------
320
321 function Index
322 (HT : Hash_Table_Type;
323 Key : Key_Type) return Hash_Type
324 is
325 begin
326 return Hash (Key) mod HT.Buckets'Length;
327 end Index;
328
329 end Ada.Containers.Hash_Tables.Generic_Keys;