1 ------------------------------------------------------------------------------
3 -- GNAT LIBRARY COMPONENTS --
5 -- A D A . C O N T A I N E R S . --
6 -- H A S H _ T A B L E S . G E N E R I C _ K E Y S --
10 -- Copyright (C) 2004-2007, Free Software Foundation, Inc. --
12 -- GNAT is free software; you can redistribute it and/or modify it under --
13 -- terms of the GNU General Public License as published by the Free Soft- --
14 -- ware Foundation; either version 2, or (at your option) any later ver- --
15 -- sion. GNAT is distributed in the hope that it will be useful, but WITH- --
16 -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY --
17 -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License --
18 -- for more details. You should have received a copy of the GNU General --
19 -- Public License distributed with GNAT; see file COPYING. If not, write --
20 -- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, --
21 -- Boston, MA 02110-1301, USA. --
23 -- As a special exception, if other files instantiate generics from this --
24 -- unit, or you link this unit with other files to produce an executable, --
25 -- this unit does not by itself cause the resulting executable to be --
26 -- covered by the GNU General Public License. This exception does not --
27 -- however invalidate any other reasons why the executable file might be --
28 -- covered by the GNU Public License. --
30 -- This unit was originally developed by Matthew J Heaney. --
31 ------------------------------------------------------------------------------
33 package body Ada
.Containers
.Hash_Tables
.Generic_Keys
is
35 --------------------------
36 -- Delete_Key_Sans_Free --
37 --------------------------
39 procedure Delete_Key_Sans_Free
40 (HT
: in out Hash_Table_Type
;
53 Indx
:= Index
(HT
, Key
);
54 X
:= HT
.Buckets
(Indx
);
60 if Equivalent_Keys
(Key
, X
) then
62 raise Program_Error
with
63 "attempt to tamper with elements (container is busy)";
65 HT
.Buckets
(Indx
) := Next
(X
);
66 HT
.Length
:= HT
.Length
- 1;
78 if Equivalent_Keys
(Key
, X
) then
80 raise Program_Error
with
81 "attempt to tamper with elements (container is busy)";
83 Set_Next
(Node
=> Prev
, Next
=> Next
(X
));
84 HT
.Length
:= HT
.Length
- 1;
88 end Delete_Key_Sans_Free
;
95 (HT
: Hash_Table_Type
;
96 Key
: Key_Type
) return Node_Access
is
102 if HT
.Length
= 0 then
106 Indx
:= Index
(HT
, Key
);
108 Node
:= HT
.Buckets
(Indx
);
109 while Node
/= null loop
110 if Equivalent_Keys
(Key
, Node
) then
119 --------------------------------
120 -- Generic_Conditional_Insert --
121 --------------------------------
123 procedure Generic_Conditional_Insert
124 (HT
: in out Hash_Table_Type
;
126 Node
: out Node_Access
;
127 Inserted
: out Boolean)
129 Indx
: constant Hash_Type
:= Index
(HT
, Key
);
130 B
: Node_Access
renames HT
.Buckets
(Indx
);
135 raise Program_Error
with
136 "attempt to tamper with elements (container is busy)";
139 if HT
.Length
= Count_Type
'Last then
140 raise Constraint_Error
;
143 Node
:= New_Node
(Next
=> null);
147 HT
.Length
:= HT
.Length
+ 1;
154 if Equivalent_Keys
(Key
, Node
) then
161 exit when Node
= null;
165 raise Program_Error
with
166 "attempt to tamper with elements (container is busy)";
169 if HT
.Length
= Count_Type
'Last then
170 raise Constraint_Error
;
173 Node
:= New_Node
(Next
=> B
);
177 HT
.Length
:= HT
.Length
+ 1;
178 end Generic_Conditional_Insert
;
185 (HT
: Hash_Table_Type
;
186 Key
: Key_Type
) return Hash_Type
is
188 return Hash
(Key
) mod HT
.Buckets
'Length;
191 -----------------------------
192 -- Generic_Replace_Element --
193 -----------------------------
195 procedure Generic_Replace_Element
196 (HT
: in out Hash_Table_Type
;
200 pragma Assert
(HT
.Length
> 0);
201 pragma Assert
(Node
/= null);
203 Old_Hash
: constant Hash_Type
:= Hash
(Node
);
204 Old_Indx
: constant Hash_Type
:= Old_Hash
mod HT
.Buckets
'Length;
206 New_Hash
: constant Hash_Type
:= Hash
(Key
);
207 New_Indx
: constant Hash_Type
:= New_Hash
mod HT
.Buckets
'Length;
209 New_Bucket
: Node_Access
renames HT
.Buckets
(New_Indx
);
213 if Equivalent_Keys
(Key
, Node
) then
214 pragma Assert
(New_Hash
= Old_Hash
);
217 raise Program_Error
with
218 "attempt to tamper with cursors (container is locked)";
221 -- We can change a node's key to Key (that's what Assign is for), but
222 -- only if Key is not already in the hash table. (In a unique-key
223 -- hash table as this one a key is mapped to exactly one node only.)
224 -- The exception is when Key is mapped to Node, in which case the
225 -- change is allowed.
228 pragma Assert
(Hash
(Node
) = New_Hash
);
229 pragma Assert
(Equivalent_Keys
(Key
, Node
));
233 -- Key is not equivalent to Node, so we now have to determine if it's
234 -- equivalent to some other node in the hash table. This is the case
235 -- irrespective of whether Key is in the same or a different bucket from
240 if Equivalent_Keys
(Key
, N
) then
241 pragma Assert
(N
/= Node
);
242 raise Program_Error
with
243 "attempt to replace existing element";
249 -- We have determined that Key is not already in the hash table, so
250 -- the change is tenatively allowed. We now perform the standard
251 -- checks to determine whether the hash table is locked (because you
252 -- cannot change an element while it's in use by Query_Element or
253 -- Update_Element), or if the container is busy (because moving a
254 -- node to a different bucket would interfere with iteration).
256 if Old_Indx
= New_Indx
then
257 -- The node is already in the bucket implied by Key. In this case
258 -- we merely change its value without moving it.
261 raise Program_Error
with
262 "attempt to tamper with cursors (container is locked)";
266 pragma Assert
(Hash
(Node
) = New_Hash
);
267 pragma Assert
(Equivalent_Keys
(Key
, Node
));
271 -- The node is a bucket different from the bucket implied by Key
274 raise Program_Error
with
275 "attempt to tamper with elements (container is busy)";
278 -- Do the assignment first, before moving the node, so that if Assign
279 -- propagates an exception, then the hash table will not have been
280 -- modified (except for any possible side-effect Assign had on Node).
283 pragma Assert
(Hash
(Node
) = New_Hash
);
284 pragma Assert
(Equivalent_Keys
(Key
, Node
));
286 -- Now we can safely remove the node from its current bucket
288 N
:= HT
.Buckets
(Old_Indx
);
289 pragma Assert
(N
/= null);
292 HT
.Buckets
(Old_Indx
) := Next
(Node
);
295 pragma Assert
(HT
.Length
> 1);
299 pragma Assert
(M
/= null);
302 Set_Next
(Node
=> N
, Next
=> Next
(Node
));
310 -- Now we link the node into its new bucket (corresponding to Key)
312 Set_Next
(Node
=> Node
, Next
=> New_Bucket
);
314 end Generic_Replace_Element
;
316 end Ada
.Containers
.Hash_Tables
.Generic_Keys
;