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