1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- ADA.CONTAINERS.HASH_TABLES.GENERIC_KEYS --
9 -- Copyright (C) 2004-2008, Free Software Foundation, Inc. --
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 2, 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. See the GNU General Public License --
17 -- for more details. You should have received a copy of the GNU General --
18 -- Public License distributed with GNAT; see file COPYING. If not, write --
19 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
20 -- Boston, MA 02110-1301, USA. --
22 -- As a special exception, if other files instantiate generics from this --
23 -- unit, or you link this unit with other files to produce an executable, --
24 -- this unit does not by itself cause the resulting executable to be --
25 -- covered by the GNU General Public License. This exception does not --
26 -- however invalidate any other reasons why the executable file might be --
27 -- covered by the GNU Public License. --
29 -- This unit was originally developed by Matthew J Heaney. --
30 ------------------------------------------------------------------------------
32 package body Ada
.Containers
.Hash_Tables
.Generic_Keys
is
34 --------------------------
35 -- Delete_Key_Sans_Free --
36 --------------------------
38 procedure Delete_Key_Sans_Free
39 (HT
: in out Hash_Table_Type
;
52 Indx
:= Index
(HT
, Key
);
53 X
:= HT
.Buckets
(Indx
);
59 if Equivalent_Keys
(Key
, X
) then
61 raise Program_Error
with
62 "attempt to tamper with elements (container is busy)";
64 HT
.Buckets
(Indx
) := Next
(X
);
65 HT
.Length
:= HT
.Length
- 1;
77 if Equivalent_Keys
(Key
, X
) then
79 raise Program_Error
with
80 "attempt to tamper with elements (container is busy)";
82 Set_Next
(Node
=> Prev
, Next
=> Next
(X
));
83 HT
.Length
:= HT
.Length
- 1;
87 end Delete_Key_Sans_Free
;
94 (HT
: Hash_Table_Type
;
95 Key
: Key_Type
) return Node_Access
is
101 if HT
.Length
= 0 then
105 Indx
:= Index
(HT
, Key
);
107 Node
:= HT
.Buckets
(Indx
);
108 while Node
/= null loop
109 if Equivalent_Keys
(Key
, Node
) then
118 --------------------------------
119 -- Generic_Conditional_Insert --
120 --------------------------------
122 procedure Generic_Conditional_Insert
123 (HT
: in out Hash_Table_Type
;
125 Node
: out Node_Access
;
126 Inserted
: out Boolean)
128 Indx
: constant Hash_Type
:= Index
(HT
, Key
);
129 B
: Node_Access
renames HT
.Buckets
(Indx
);
134 raise Program_Error
with
135 "attempt to tamper with elements (container is busy)";
138 if HT
.Length
= Count_Type
'Last then
139 raise Constraint_Error
;
142 Node
:= New_Node
(Next
=> null);
146 HT
.Length
:= HT
.Length
+ 1;
153 if Equivalent_Keys
(Key
, Node
) then
160 exit when Node
= null;
164 raise Program_Error
with
165 "attempt to tamper with elements (container is busy)";
168 if HT
.Length
= Count_Type
'Last then
169 raise Constraint_Error
;
172 Node
:= New_Node
(Next
=> B
);
176 HT
.Length
:= HT
.Length
+ 1;
177 end Generic_Conditional_Insert
;
184 (HT
: Hash_Table_Type
;
185 Key
: Key_Type
) return Hash_Type
is
187 return Hash
(Key
) mod HT
.Buckets
'Length;
190 -----------------------------
191 -- Generic_Replace_Element --
192 -----------------------------
194 procedure Generic_Replace_Element
195 (HT
: in out Hash_Table_Type
;
199 pragma Assert
(HT
.Length
> 0);
200 pragma Assert
(Node
/= null);
202 Old_Hash
: constant Hash_Type
:= Hash
(Node
);
203 Old_Indx
: constant Hash_Type
:= Old_Hash
mod HT
.Buckets
'Length;
205 New_Hash
: constant Hash_Type
:= Hash
(Key
);
206 New_Indx
: constant Hash_Type
:= New_Hash
mod HT
.Buckets
'Length;
208 New_Bucket
: Node_Access
renames HT
.Buckets
(New_Indx
);
212 if Equivalent_Keys
(Key
, Node
) then
213 pragma Assert
(New_Hash
= Old_Hash
);
216 raise Program_Error
with
217 "attempt to tamper with cursors (container is locked)";
220 -- We can change a node's key to Key (that's what Assign is for), but
221 -- only if Key is not already in the hash table. (In a unique-key
222 -- hash table as this one a key is mapped to exactly one node only.)
223 -- The exception is when Key is mapped to Node, in which case the
224 -- change is allowed.
227 pragma Assert
(Hash
(Node
) = New_Hash
);
228 pragma Assert
(Equivalent_Keys
(Key
, Node
));
232 -- Key is not equivalent to Node, so we now have to determine if it's
233 -- equivalent to some other node in the hash table. This is the case
234 -- irrespective of whether Key is in the same or a different bucket from
239 if Equivalent_Keys
(Key
, N
) then
240 pragma Assert
(N
/= Node
);
241 raise Program_Error
with
242 "attempt to replace existing element";
248 -- We have determined that Key is not already in the hash table, so
249 -- the change is tentatively allowed. We now perform the standard
250 -- checks to determine whether the hash table is locked (because you
251 -- cannot change an element while it's in use by Query_Element or
252 -- Update_Element), or if the container is busy (because moving a
253 -- node to a different bucket would interfere with iteration).
255 if Old_Indx
= New_Indx
then
256 -- The node is already in the bucket implied by Key. In this case
257 -- we merely change its value without moving it.
260 raise Program_Error
with
261 "attempt to tamper with cursors (container is locked)";
265 pragma Assert
(Hash
(Node
) = New_Hash
);
266 pragma Assert
(Equivalent_Keys
(Key
, Node
));
270 -- The node is a bucket different from the bucket implied by Key
273 raise Program_Error
with
274 "attempt to tamper with elements (container is busy)";
277 -- Do the assignment first, before moving the node, so that if Assign
278 -- propagates an exception, then the hash table will not have been
279 -- modified (except for any possible side-effect Assign had on Node).
282 pragma Assert
(Hash
(Node
) = New_Hash
);
283 pragma Assert
(Equivalent_Keys
(Key
, Node
));
285 -- Now we can safely remove the node from its current bucket
287 N
:= HT
.Buckets
(Old_Indx
);
288 pragma Assert
(N
/= null);
291 HT
.Buckets
(Old_Indx
) := Next
(Node
);
294 pragma Assert
(HT
.Length
> 1);
298 pragma Assert
(M
/= null);
301 Set_Next
(Node
=> N
, Next
=> Next
(Node
));
309 -- Now we link the node into its new bucket (corresponding to Key)
311 Set_Next
(Node
=> Node
, Next
=> New_Bucket
);
313 end Generic_Replace_Element
;
315 end Ada
.Containers
.Hash_Tables
.Generic_Keys
;