1------------------------------------------------------------------------------ 2-- -- 3-- GNAT LIBRARY COMPONENTS -- 4-- -- 5-- ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_OPERATIONS -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2004-2015, 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 30with System; use type System.Address; 31 32package body Ada.Containers.Hash_Tables.Generic_Bounded_Operations is 33 34 pragma Warnings (Off, "variable ""Busy*"" is not referenced"); 35 pragma Warnings (Off, "variable ""Lock*"" is not referenced"); 36 -- See comment in Ada.Containers.Helpers 37 38 ------------------- 39 -- Checked_Index -- 40 ------------------- 41 42 function Checked_Index 43 (Hash_Table : aliased in out Hash_Table_Type'Class; 44 Node : Count_Type) return Hash_Type 45 is 46 Lock : With_Lock (Hash_Table.TC'Unrestricted_Access); 47 begin 48 return Index (Hash_Table, Hash_Table.Nodes (Node)); 49 end Checked_Index; 50 51 ----------- 52 -- Clear -- 53 ----------- 54 55 procedure Clear (HT : in out Hash_Table_Type'Class) is 56 begin 57 TC_Check (HT.TC); 58 59 HT.Length := 0; 60 -- HT.Busy := 0; 61 -- HT.Lock := 0; 62 HT.Free := -1; 63 HT.Buckets := (others => 0); -- optimize this somehow ??? 64 end Clear; 65 66 -------------------------- 67 -- Delete_Node_At_Index -- 68 -------------------------- 69 70 procedure Delete_Node_At_Index 71 (HT : in out Hash_Table_Type'Class; 72 Indx : Hash_Type; 73 X : Count_Type) 74 is 75 Prev : Count_Type; 76 Curr : Count_Type; 77 78 begin 79 Prev := HT.Buckets (Indx); 80 81 if Checks and then Prev = 0 then 82 raise Program_Error with 83 "attempt to delete node from empty hash bucket"; 84 end if; 85 86 if Prev = X then 87 HT.Buckets (Indx) := Next (HT.Nodes (Prev)); 88 HT.Length := HT.Length - 1; 89 return; 90 end if; 91 92 if Checks and then HT.Length = 1 then 93 raise Program_Error with 94 "attempt to delete node not in its proper hash bucket"; 95 end if; 96 97 loop 98 Curr := Next (HT.Nodes (Prev)); 99 100 if Checks and then Curr = 0 then 101 raise Program_Error with 102 "attempt to delete node not in its proper hash bucket"; 103 end if; 104 105 Prev := Curr; 106 end loop; 107 end Delete_Node_At_Index; 108 109 --------------------------- 110 -- Delete_Node_Sans_Free -- 111 --------------------------- 112 113 procedure Delete_Node_Sans_Free 114 (HT : in out Hash_Table_Type'Class; 115 X : Count_Type) 116 is 117 pragma Assert (X /= 0); 118 119 Indx : Hash_Type; 120 Prev : Count_Type; 121 Curr : Count_Type; 122 123 begin 124 if Checks and then HT.Length = 0 then 125 raise Program_Error with 126 "attempt to delete node from empty hashed container"; 127 end if; 128 129 Indx := Checked_Index (HT, X); 130 Prev := HT.Buckets (Indx); 131 132 if Checks and then Prev = 0 then 133 raise Program_Error with 134 "attempt to delete node from empty hash bucket"; 135 end if; 136 137 if Prev = X then 138 HT.Buckets (Indx) := Next (HT.Nodes (Prev)); 139 HT.Length := HT.Length - 1; 140 return; 141 end if; 142 143 if Checks and then HT.Length = 1 then 144 raise Program_Error with 145 "attempt to delete node not in its proper hash bucket"; 146 end if; 147 148 loop 149 Curr := Next (HT.Nodes (Prev)); 150 151 if Checks and then Curr = 0 then 152 raise Program_Error with 153 "attempt to delete node not in its proper hash bucket"; 154 end if; 155 156 if Curr = X then 157 Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (Curr))); 158 HT.Length := HT.Length - 1; 159 return; 160 end if; 161 162 Prev := Curr; 163 end loop; 164 end Delete_Node_Sans_Free; 165 166 ----------- 167 -- First -- 168 ----------- 169 170 function First (HT : Hash_Table_Type'Class) return Count_Type is 171 Indx : Hash_Type; 172 173 begin 174 if HT.Length = 0 then 175 return 0; 176 end if; 177 178 Indx := HT.Buckets'First; 179 loop 180 if HT.Buckets (Indx) /= 0 then 181 return HT.Buckets (Indx); 182 end if; 183 184 Indx := Indx + 1; 185 end loop; 186 end First; 187 188 ---------- 189 -- Free -- 190 ---------- 191 192 procedure Free 193 (HT : in out Hash_Table_Type'Class; 194 X : Count_Type) 195 is 196 N : Nodes_Type renames HT.Nodes; 197 198 begin 199 -- This subprogram "deallocates" a node by relinking the node off of the 200 -- active list and onto the free list. Previously it would flag index 201 -- value 0 as an error. The precondition was weakened, so that index 202 -- value 0 is now allowed, and this value is interpreted to mean "do 203 -- nothing". This makes its behavior analogous to the behavior of 204 -- Ada.Unchecked_Deallocation, and allows callers to avoid having to add 205 -- special-case checks at the point of call. 206 207 if X = 0 then 208 return; 209 end if; 210 211 pragma Assert (X <= HT.Capacity); 212 213 -- pragma Assert (N (X).Prev >= 0); -- node is active 214 -- Find a way to mark a node as active vs. inactive; we could 215 -- use a special value in Color_Type for this. ??? 216 217 -- The hash table actually contains two data structures: a list for 218 -- the "active" nodes that contain elements that have been inserted 219 -- onto the container, and another for the "inactive" nodes of the free 220 -- store. 221 -- 222 -- We desire that merely declaring an object should have only minimal 223 -- cost; specially, we want to avoid having to initialize the free 224 -- store (to fill in the links), especially if the capacity is large. 225 -- 226 -- The head of the free list is indicated by Container.Free. If its 227 -- value is non-negative, then the free store has been initialized 228 -- in the "normal" way: Container.Free points to the head of the list 229 -- of free (inactive) nodes, and the value 0 means the free list is 230 -- empty. Each node on the free list has been initialized to point 231 -- to the next free node (via its Parent component), and the value 0 232 -- means that this is the last free node. 233 -- 234 -- If Container.Free is negative, then the links on the free store 235 -- have not been initialized. In this case the link values are 236 -- implied: the free store comprises the components of the node array 237 -- started with the absolute value of Container.Free, and continuing 238 -- until the end of the array (Nodes'Last). 239 -- 240 -- ??? 241 -- It might be possible to perform an optimization here. Suppose that 242 -- the free store can be represented as having two parts: one 243 -- comprising the non-contiguous inactive nodes linked together 244 -- in the normal way, and the other comprising the contiguous 245 -- inactive nodes (that are not linked together, at the end of the 246 -- nodes array). This would allow us to never have to initialize 247 -- the free store, except in a lazy way as nodes become inactive. 248 249 -- When an element is deleted from the list container, its node 250 -- becomes inactive, and so we set its Next component to value of 251 -- the node's index (in the nodes array), to indicate that it is 252 -- now inactive. This provides a useful way to detect a dangling 253 -- cursor reference. ??? 254 255 Set_Next (N (X), Next => X); -- Node is deallocated (not on active list) 256 257 if HT.Free >= 0 then 258 -- The free store has previously been initialized. All we need to 259 -- do here is link the newly-free'd node onto the free list. 260 261 Set_Next (N (X), HT.Free); 262 HT.Free := X; 263 264 elsif X + 1 = abs HT.Free then 265 -- The free store has not been initialized, and the node becoming 266 -- inactive immediately precedes the start of the free store. All 267 -- we need to do is move the start of the free store back by one. 268 269 HT.Free := HT.Free + 1; 270 271 else 272 -- The free store has not been initialized, and the node becoming 273 -- inactive does not immediately precede the free store. Here we 274 -- first initialize the free store (meaning the links are given 275 -- values in the traditional way), and then link the newly-free'd 276 -- node onto the head of the free store. 277 278 -- ??? 279 -- See the comments above for an optimization opportunity. If 280 -- the next link for a node on the free store is negative, then 281 -- this means the remaining nodes on the free store are 282 -- physically contiguous, starting as the absolute value of 283 -- that index value. 284 285 HT.Free := abs HT.Free; 286 287 if HT.Free > HT.Capacity then 288 HT.Free := 0; 289 290 else 291 for I in HT.Free .. HT.Capacity - 1 loop 292 Set_Next (Node => N (I), Next => I + 1); 293 end loop; 294 295 Set_Next (Node => N (HT.Capacity), Next => 0); 296 end if; 297 298 Set_Next (Node => N (X), Next => HT.Free); 299 HT.Free := X; 300 end if; 301 end Free; 302 303 ---------------------- 304 -- Generic_Allocate -- 305 ---------------------- 306 307 procedure Generic_Allocate 308 (HT : in out Hash_Table_Type'Class; 309 Node : out Count_Type) 310 is 311 N : Nodes_Type renames HT.Nodes; 312 313 begin 314 if HT.Free >= 0 then 315 Node := HT.Free; 316 317 -- We always perform the assignment first, before we 318 -- change container state, in order to defend against 319 -- exceptions duration assignment. 320 321 Set_Element (N (Node)); 322 HT.Free := Next (N (Node)); 323 324 else 325 -- A negative free store value means that the links of the nodes 326 -- in the free store have not been initialized. In this case, the 327 -- nodes are physically contiguous in the array, starting at the 328 -- index that is the absolute value of the Container.Free, and 329 -- continuing until the end of the array (Nodes'Last). 330 331 Node := abs HT.Free; 332 333 -- As above, we perform this assignment first, before modifying 334 -- any container state. 335 336 Set_Element (N (Node)); 337 HT.Free := HT.Free - 1; 338 end if; 339 end Generic_Allocate; 340 341 ------------------- 342 -- Generic_Equal -- 343 ------------------- 344 345 function Generic_Equal 346 (L, R : Hash_Table_Type'Class) return Boolean 347 is 348 -- Per AI05-0022, the container implementation is required to detect 349 -- element tampering by a generic actual subprogram. 350 351 Lock_L : With_Lock (L.TC'Unrestricted_Access); 352 Lock_R : With_Lock (R.TC'Unrestricted_Access); 353 354 L_Index : Hash_Type; 355 L_Node : Count_Type; 356 357 N : Count_Type; 358 359 begin 360 if L'Address = R'Address then 361 return True; 362 end if; 363 364 if L.Length /= R.Length then 365 return False; 366 end if; 367 368 if L.Length = 0 then 369 return True; 370 end if; 371 372 -- Find the first node of hash table L 373 374 L_Index := L.Buckets'First; 375 loop 376 L_Node := L.Buckets (L_Index); 377 exit when L_Node /= 0; 378 L_Index := L_Index + 1; 379 end loop; 380 381 -- For each node of hash table L, search for an equivalent node in hash 382 -- table R. 383 384 N := L.Length; 385 loop 386 if not Find (HT => R, Key => L.Nodes (L_Node)) then 387 return False; 388 end if; 389 390 N := N - 1; 391 392 L_Node := Next (L.Nodes (L_Node)); 393 394 if L_Node = 0 then 395 396 -- We have exhausted the nodes in this bucket 397 398 if N = 0 then 399 return True; 400 end if; 401 402 -- Find the next bucket 403 404 loop 405 L_Index := L_Index + 1; 406 L_Node := L.Buckets (L_Index); 407 exit when L_Node /= 0; 408 end loop; 409 end if; 410 end loop; 411 end Generic_Equal; 412 413 ----------------------- 414 -- Generic_Iteration -- 415 ----------------------- 416 417 procedure Generic_Iteration (HT : Hash_Table_Type'Class) is 418 Node : Count_Type; 419 420 begin 421 if HT.Length = 0 then 422 return; 423 end if; 424 425 for Indx in HT.Buckets'Range loop 426 Node := HT.Buckets (Indx); 427 while Node /= 0 loop 428 Process (Node); 429 Node := Next (HT.Nodes (Node)); 430 end loop; 431 end loop; 432 end Generic_Iteration; 433 434 ------------------ 435 -- Generic_Read -- 436 ------------------ 437 438 procedure Generic_Read 439 (Stream : not null access Root_Stream_Type'Class; 440 HT : out Hash_Table_Type'Class) 441 is 442 N : Count_Type'Base; 443 444 begin 445 Clear (HT); 446 447 Count_Type'Base'Read (Stream, N); 448 449 if Checks and then N < 0 then 450 raise Program_Error with "stream appears to be corrupt"; 451 end if; 452 453 if N = 0 then 454 return; 455 end if; 456 457 if Checks and then N > HT.Capacity then 458 raise Capacity_Error with "too many elements in stream"; 459 end if; 460 461 for J in 1 .. N loop 462 declare 463 Node : constant Count_Type := New_Node (Stream); 464 Indx : constant Hash_Type := Checked_Index (HT, Node); 465 B : Count_Type renames HT.Buckets (Indx); 466 begin 467 Set_Next (HT.Nodes (Node), Next => B); 468 B := Node; 469 end; 470 471 HT.Length := HT.Length + 1; 472 end loop; 473 end Generic_Read; 474 475 ------------------- 476 -- Generic_Write -- 477 ------------------- 478 479 procedure Generic_Write 480 (Stream : not null access Root_Stream_Type'Class; 481 HT : Hash_Table_Type'Class) 482 is 483 procedure Write (Node : Count_Type); 484 pragma Inline (Write); 485 486 procedure Write is new Generic_Iteration (Write); 487 488 ----------- 489 -- Write -- 490 ----------- 491 492 procedure Write (Node : Count_Type) is 493 begin 494 Write (Stream, HT.Nodes (Node)); 495 end Write; 496 497 begin 498 Count_Type'Base'Write (Stream, HT.Length); 499 Write (HT); 500 end Generic_Write; 501 502 ----------- 503 -- Index -- 504 ----------- 505 506 function Index 507 (Buckets : Buckets_Type; 508 Node : Node_Type) return Hash_Type is 509 begin 510 return Buckets'First + Hash_Node (Node) mod Buckets'Length; 511 end Index; 512 513 function Index 514 (HT : Hash_Table_Type'Class; 515 Node : Node_Type) return Hash_Type is 516 begin 517 return Index (HT.Buckets, Node); 518 end Index; 519 520 ---------- 521 -- Next -- 522 ---------- 523 524 function Next 525 (HT : Hash_Table_Type'Class; 526 Node : Count_Type) return Count_Type 527 is 528 Result : Count_Type; 529 First : Hash_Type; 530 531 begin 532 Result := Next (HT.Nodes (Node)); 533 534 if Result /= 0 then -- another node in same bucket 535 return Result; 536 end if; 537 538 -- This was the last node in the bucket, so move to the next 539 -- bucket, and start searching for next node from there. 540 541 First := Checked_Index (HT'Unrestricted_Access.all, Node) + 1; 542 for Indx in First .. HT.Buckets'Last loop 543 Result := HT.Buckets (Indx); 544 545 if Result /= 0 then -- bucket is not empty 546 return Result; 547 end if; 548 end loop; 549 550 return 0; 551 end Next; 552 553end Ada.Containers.Hash_Tables.Generic_Bounded_Operations; 554