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-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_Bounded_Keys is 31 32 ----------------------------- 33 -- Checked_Equivalent_Keys -- 34 ----------------------------- 35 36 function Checked_Equivalent_Keys 37 (HT : aliased in out Hash_Table_Type'Class; 38 Key : Key_Type; 39 Node : Count_Type) 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, HT.Nodes (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'Class; 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 := HT.Buckets'First + 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'Class; 103 Key : Key_Type; 104 X : out Count_Type) 105 is 106 Indx : Hash_Type; 107 Prev : Count_Type; 108 109 begin 110 if HT.Length = 0 then 111 X := 0; 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 = 0 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 (HT.Nodes (X)); 136 HT.Length := HT.Length - 1; 137 return; 138 end if; 139 140 loop 141 Prev := X; 142 X := Next (HT.Nodes (Prev)); 143 144 if X = 0 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 (HT.Nodes (Prev), Next => Next (HT.Nodes (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 : Hash_Table_Type'Class; 166 Key : Key_Type) return Count_Type 167 is 168 Indx : Hash_Type; 169 Node : Count_Type; 170 171 begin 172 if HT.Length = 0 then 173 return 0; 174 end if; 175 176 Indx := Checked_Index (HT'Unrestricted_Access.all, Key); 177 178 Node := HT.Buckets (Indx); 179 while Node /= 0 loop 180 if Checked_Equivalent_Keys 181 (HT'Unrestricted_Access.all, Key, Node) 182 then 183 return Node; 184 end if; 185 Node := Next (HT.Nodes (Node)); 186 end loop; 187 188 return 0; 189 end Find; 190 191 -------------------------------- 192 -- Generic_Conditional_Insert -- 193 -------------------------------- 194 195 procedure Generic_Conditional_Insert 196 (HT : in out Hash_Table_Type'Class; 197 Key : Key_Type; 198 Node : out Count_Type; 199 Inserted : out Boolean) 200 is 201 Indx : Hash_Type; 202 203 begin 204 -- Per AI05-0022, the container implementation is required to detect 205 -- element tampering by a generic actual subprogram. 206 207 if HT.Busy > 0 then 208 raise Program_Error with 209 "attempt to tamper with cursors (container is busy)"; 210 end if; 211 212 Indx := Checked_Index (HT, Key); 213 Node := HT.Buckets (Indx); 214 215 if Node = 0 then 216 if HT.Length = HT.Capacity then 217 raise Capacity_Error with "no more capacity for insertion"; 218 end if; 219 220 Node := New_Node; 221 Set_Next (HT.Nodes (Node), Next => 0); 222 223 Inserted := True; 224 225 HT.Buckets (Indx) := Node; 226 HT.Length := HT.Length + 1; 227 228 return; 229 end if; 230 231 loop 232 if Checked_Equivalent_Keys (HT, Key, Node) then 233 Inserted := False; 234 return; 235 end if; 236 237 Node := Next (HT.Nodes (Node)); 238 239 exit when Node = 0; 240 end loop; 241 242 if HT.Length = HT.Capacity then 243 raise Capacity_Error with "no more capacity for insertion"; 244 end if; 245 246 Node := New_Node; 247 Set_Next (HT.Nodes (Node), Next => HT.Buckets (Indx)); 248 249 Inserted := True; 250 251 HT.Buckets (Indx) := Node; 252 HT.Length := HT.Length + 1; 253 end Generic_Conditional_Insert; 254 255 ----------------------------- 256 -- Generic_Replace_Element -- 257 ----------------------------- 258 259 procedure Generic_Replace_Element 260 (HT : in out Hash_Table_Type'Class; 261 Node : Count_Type; 262 Key : Key_Type) 263 is 264 pragma Assert (HT.Length > 0); 265 pragma Assert (Node /= 0); 266 267 BB : Buckets_Type renames HT.Buckets; 268 NN : Nodes_Type renames HT.Nodes; 269 270 Old_Indx : Hash_Type; 271 New_Indx : constant Hash_Type := Checked_Index (HT, Key); 272 273 New_Bucket : Count_Type renames BB (New_Indx); 274 N, M : Count_Type; 275 276 begin 277 -- Per AI05-0022, the container implementation is required to detect 278 -- element tampering by a generic actual subprogram. 279 280 -- The following block appears to be vestigial -- this should be done 281 -- using Checked_Index instead. Also, we might have to move the actual 282 -- tampering checks to the top of the subprogram, in order to prevent 283 -- infinite recursion when calling Hash. (This is similar to how Insert 284 -- and Delete are implemented.) This implies that we will have to defer 285 -- the computation of New_Index until after the tampering check. ??? 286 287 declare 288 B : Natural renames HT.Busy; 289 L : Natural renames HT.Lock; 290 291 begin 292 B := B + 1; 293 L := L + 1; 294 295 Old_Indx := HT.Buckets'First + Hash (NN (Node)) mod HT.Buckets'Length; 296 297 B := B - 1; 298 L := L - 1; 299 300 exception 301 when others => 302 B := B - 1; 303 L := L - 1; 304 305 raise; 306 end; 307 308 -- Replace_Element is allowed to change a node's key to Key 309 -- (generic formal operation Assign provides the mechanism), but 310 -- only if Key is not already in the hash table. (In a unique-key 311 -- hash table as this one, a key is mapped to exactly one node.) 312 313 if Checked_Equivalent_Keys (HT, Key, Node) then 314 if HT.Lock > 0 then 315 raise Program_Error with 316 "attempt to tamper with elements (container is locked)"; 317 end if; 318 319 -- The new Key value is mapped to this same Node, so Node 320 -- stays in the same bucket. 321 322 Assign (NN (Node), Key); 323 return; 324 end if; 325 326 -- Key is not equivalent to Node, so we now have to determine if it's 327 -- equivalent to some other node in the hash table. This is the case 328 -- irrespective of whether Key is in the same or a different bucket from 329 -- Node. 330 331 N := New_Bucket; 332 while N /= 0 loop 333 if Checked_Equivalent_Keys (HT, Key, N) then 334 pragma Assert (N /= Node); 335 raise Program_Error with 336 "attempt to replace existing element"; 337 end if; 338 339 N := Next (NN (N)); 340 end loop; 341 342 -- We have determined that Key is not already in the hash table, so 343 -- the change is tentatively allowed. We now perform the standard 344 -- checks to determine whether the hash table is locked (because you 345 -- cannot change an element while it's in use by Query_Element or 346 -- Update_Element), or if the container is busy (because moving a 347 -- node to a different bucket would interfere with iteration). 348 349 if Old_Indx = New_Indx then 350 -- The node is already in the bucket implied by Key. In this case 351 -- we merely change its value without moving it. 352 353 if HT.Lock > 0 then 354 raise Program_Error with 355 "attempt to tamper with elements (container is locked)"; 356 end if; 357 358 Assign (NN (Node), Key); 359 return; 360 end if; 361 362 -- The node is a bucket different from the bucket implied by Key 363 364 if HT.Busy > 0 then 365 raise Program_Error with 366 "attempt to tamper with cursors (container is busy)"; 367 end if; 368 369 -- Do the assignment first, before moving the node, so that if Assign 370 -- propagates an exception, then the hash table will not have been 371 -- modified (except for any possible side-effect Assign had on Node). 372 373 Assign (NN (Node), Key); 374 375 -- Now we can safely remove the node from its current bucket 376 377 N := BB (Old_Indx); -- get value of first node in old bucket 378 pragma Assert (N /= 0); 379 380 if N = Node then -- node is first node in its bucket 381 BB (Old_Indx) := Next (NN (Node)); 382 383 else 384 pragma Assert (HT.Length > 1); 385 386 loop 387 M := Next (NN (N)); 388 pragma Assert (M /= 0); 389 390 if M = Node then 391 Set_Next (NN (N), Next => Next (NN (Node))); 392 exit; 393 end if; 394 395 N := M; 396 end loop; 397 end if; 398 399 -- Now we link the node into its new bucket (corresponding to Key) 400 401 Set_Next (NN (Node), Next => New_Bucket); 402 New_Bucket := Node; 403 end Generic_Replace_Element; 404 405 ----------- 406 -- Index -- 407 ----------- 408 409 function Index 410 (HT : Hash_Table_Type'Class; 411 Key : Key_Type) return Hash_Type is 412 begin 413 return HT.Buckets'First + Hash (Key) mod HT.Buckets'Length; 414 end Index; 415 416end Ada.Containers.Hash_Tables.Generic_Bounded_Keys; 417