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-2013, 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_Keys is 31 32 ----------------------------- 33 -- Checked_Equivalent_Keys -- 34 ----------------------------- 35 36 function Checked_Equivalent_Keys 37 (HT : aliased in out Hash_Table_Type; 38 Key : Key_Type; 39 Node : Node_Access) return Boolean 40 is 41 Result : Boolean; 42 43 B : Natural renames HT.Busy; 44 L : Natural renames HT.Lock; 45 46 begin 47 B := B + 1; 48 L := L + 1; 49 50 Result := Equivalent_Keys (Key, Node); 51 52 B := B - 1; 53 L := L - 1; 54 55 return Result; 56 57 exception 58 when others => 59 B := B - 1; 60 L := L - 1; 61 62 raise; 63 end Checked_Equivalent_Keys; 64 65 ------------------- 66 -- Checked_Index -- 67 ------------------- 68 69 function Checked_Index 70 (HT : aliased in out Hash_Table_Type; 71 Key : Key_Type) return Hash_Type 72 is 73 Result : Hash_Type; 74 75 B : Natural renames HT.Busy; 76 L : Natural renames HT.Lock; 77 78 begin 79 B := B + 1; 80 L := L + 1; 81 82 Result := Hash (Key) mod HT.Buckets'Length; 83 84 B := B - 1; 85 L := L - 1; 86 87 return Result; 88 89 exception 90 when others => 91 B := B - 1; 92 L := L - 1; 93 94 raise; 95 end Checked_Index; 96 97 -------------------------- 98 -- Delete_Key_Sans_Free -- 99 -------------------------- 100 101 procedure Delete_Key_Sans_Free 102 (HT : in out Hash_Table_Type; 103 Key : Key_Type; 104 X : out Node_Access) 105 is 106 Indx : Hash_Type; 107 Prev : Node_Access; 108 109 begin 110 if HT.Length = 0 then 111 X := null; 112 return; 113 end if; 114 115 -- Per AI05-0022, the container implementation is required to detect 116 -- element tampering by a generic actual subprogram. 117 118 if HT.Busy > 0 then 119 raise Program_Error with 120 "attempt to tamper with cursors (container is busy)"; 121 end if; 122 123 Indx := Checked_Index (HT, Key); 124 X := HT.Buckets (Indx); 125 126 if X = null then 127 return; 128 end if; 129 130 if Checked_Equivalent_Keys (HT, Key, X) 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 HT.Buckets (Indx) := Next (X); 136 HT.Length := HT.Length - 1; 137 return; 138 end if; 139 140 loop 141 Prev := X; 142 X := Next (Prev); 143 144 if X = null then 145 return; 146 end if; 147 148 if Checked_Equivalent_Keys (HT, Key, X) then 149 if HT.Busy > 0 then 150 raise Program_Error with 151 "attempt to tamper with cursors (container is busy)"; 152 end if; 153 Set_Next (Node => Prev, Next => Next (X)); 154 HT.Length := HT.Length - 1; 155 return; 156 end if; 157 end loop; 158 end Delete_Key_Sans_Free; 159 160 ---------- 161 -- Find -- 162 ---------- 163 164 function Find 165 (HT : aliased in out Hash_Table_Type; 166 Key : Key_Type) return Node_Access 167 is 168 Indx : Hash_Type; 169 Node : Node_Access; 170 171 begin 172 if HT.Length = 0 then 173 return null; 174 end if; 175 176 Indx := Checked_Index (HT, Key); 177 178 Node := HT.Buckets (Indx); 179 while Node /= null loop 180 if Checked_Equivalent_Keys (HT, Key, Node) then 181 return Node; 182 end if; 183 Node := Next (Node); 184 end loop; 185 186 return null; 187 end Find; 188 189 -------------------------------- 190 -- Generic_Conditional_Insert -- 191 -------------------------------- 192 193 procedure Generic_Conditional_Insert 194 (HT : in out Hash_Table_Type; 195 Key : Key_Type; 196 Node : out Node_Access; 197 Inserted : out Boolean) 198 is 199 Indx : Hash_Type; 200 201 begin 202 -- Per AI05-0022, the container implementation is required to detect 203 -- element tampering by a generic actual subprogram. 204 205 if HT.Busy > 0 then 206 raise Program_Error with 207 "attempt to tamper with cursors (container is busy)"; 208 end if; 209 210 Indx := Checked_Index (HT, Key); 211 Node := HT.Buckets (Indx); 212 213 if Node = null then 214 if HT.Length = Count_Type'Last then 215 raise Constraint_Error; 216 end if; 217 218 Node := New_Node (Next => null); 219 Inserted := True; 220 221 HT.Buckets (Indx) := Node; 222 HT.Length := HT.Length + 1; 223 224 return; 225 end if; 226 227 loop 228 if Checked_Equivalent_Keys (HT, Key, Node) then 229 Inserted := False; 230 return; 231 end if; 232 233 Node := Next (Node); 234 235 exit when Node = null; 236 end loop; 237 238 if HT.Length = Count_Type'Last then 239 raise Constraint_Error; 240 end if; 241 242 Node := New_Node (Next => HT.Buckets (Indx)); 243 Inserted := True; 244 245 HT.Buckets (Indx) := Node; 246 HT.Length := HT.Length + 1; 247 end Generic_Conditional_Insert; 248 249 ----------------------------- 250 -- Generic_Replace_Element -- 251 ----------------------------- 252 253 procedure Generic_Replace_Element 254 (HT : in out Hash_Table_Type; 255 Node : Node_Access; 256 Key : Key_Type) 257 is 258 pragma Assert (HT.Length > 0); 259 pragma Assert (Node /= null); 260 261 Old_Indx : Hash_Type; 262 New_Indx : constant Hash_Type := Checked_Index (HT, Key); 263 264 New_Bucket : Node_Access renames HT.Buckets (New_Indx); 265 N, M : Node_Access; 266 267 begin 268 -- Per AI05-0022, the container implementation is required to detect 269 -- element tampering by a generic actual subprogram. 270 271 declare 272 B : Natural renames HT.Busy; 273 L : Natural renames HT.Lock; 274 275 begin 276 B := B + 1; 277 L := L + 1; 278 279 Old_Indx := Hash (Node) mod HT.Buckets'Length; 280 281 B := B - 1; 282 L := L - 1; 283 284 exception 285 when others => 286 B := B - 1; 287 L := L - 1; 288 289 raise; 290 end; 291 292 if Checked_Equivalent_Keys (HT, Key, Node) then 293 if HT.Lock > 0 then 294 raise Program_Error with 295 "attempt to tamper with elements (container is locked)"; 296 end if; 297 298 -- We can change a node's key to Key (that's what Assign is for), but 299 -- only if Key is not already in the hash table. (In a unique-key 300 -- hash table as this one a key is mapped to exactly one node only.) 301 -- The exception is when Key is mapped to Node, in which case the 302 -- change is allowed. 303 304 Assign (Node, Key); 305 return; 306 end if; 307 308 -- Key is not equivalent to Node, so we now have to determine if it's 309 -- equivalent to some other node in the hash table. This is the case 310 -- irrespective of whether Key is in the same or a different bucket from 311 -- Node. 312 313 N := New_Bucket; 314 while N /= null loop 315 if Checked_Equivalent_Keys (HT, Key, N) then 316 pragma Assert (N /= Node); 317 raise Program_Error with 318 "attempt to replace existing element"; 319 end if; 320 321 N := Next (N); 322 end loop; 323 324 -- We have determined that Key is not already in the hash table, so 325 -- the change is tentatively allowed. We now perform the standard 326 -- checks to determine whether the hash table is locked (because you 327 -- cannot change an element while it's in use by Query_Element or 328 -- Update_Element), or if the container is busy (because moving a 329 -- node to a different bucket would interfere with iteration). 330 331 if Old_Indx = New_Indx then 332 -- The node is already in the bucket implied by Key. In this case 333 -- we merely change its value without moving it. 334 335 if HT.Lock > 0 then 336 raise Program_Error with 337 "attempt to tamper with elements (container is locked)"; 338 end if; 339 340 Assign (Node, Key); 341 return; 342 end if; 343 344 -- The node is a bucket different from the bucket implied by Key 345 346 if HT.Busy > 0 then 347 raise Program_Error with 348 "attempt to tamper with cursors (container is busy)"; 349 end if; 350 351 -- Do the assignment first, before moving the node, so that if Assign 352 -- propagates an exception, then the hash table will not have been 353 -- modified (except for any possible side-effect Assign had on Node). 354 355 Assign (Node, Key); 356 357 -- Now we can safely remove the node from its current bucket 358 359 N := HT.Buckets (Old_Indx); 360 pragma Assert (N /= null); 361 362 if N = Node then 363 HT.Buckets (Old_Indx) := Next (Node); 364 365 else 366 pragma Assert (HT.Length > 1); 367 368 loop 369 M := Next (N); 370 pragma Assert (M /= null); 371 372 if M = Node then 373 Set_Next (Node => N, Next => Next (Node)); 374 exit; 375 end if; 376 377 N := M; 378 end loop; 379 end if; 380 381 -- Now we link the node into its new bucket (corresponding to Key) 382 383 Set_Next (Node => Node, Next => New_Bucket); 384 New_Bucket := Node; 385 end Generic_Replace_Element; 386 387 ----------- 388 -- Index -- 389 ----------- 390 391 function Index 392 (HT : Hash_Table_Type; 393 Key : Key_Type) return Hash_Type 394 is 395 begin 396 return Hash (Key) mod HT.Buckets'Length; 397 end Index; 398 399end Ada.Containers.Hash_Tables.Generic_Keys; 400