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