1------------------------------------------------------------------------------ 2-- -- 3-- GNAT RUN-TIME COMPONENTS -- 4-- -- 5-- G N A T . D Y N A M I C _ H T A B L E S -- 6-- -- 7-- B o d y -- 8-- -- 9-- Copyright (C) 2002-2015, AdaCore -- 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-- GNAT was originally developed by the GNAT team at New York University. -- 28-- Extensive contributions were provided by Ada Core Technologies Inc. -- 29-- -- 30------------------------------------------------------------------------------ 31 32with Ada.Unchecked_Deallocation; 33 34package body GNAT.Dynamic_HTables is 35 36 ------------------- 37 -- Static_HTable -- 38 ------------------- 39 40 package body Static_HTable is 41 42 type Table_Type is array (Header_Num) of Elmt_Ptr; 43 44 type Instance_Data is record 45 Table : Table_Type; 46 Iterator_Index : Header_Num; 47 Iterator_Ptr : Elmt_Ptr; 48 Iterator_Started : Boolean := False; 49 end record; 50 51 function Get_Non_Null (T : Instance) return Elmt_Ptr; 52 -- Returns Null_Ptr if Iterator_Started is False or if the Table is 53 -- empty. Returns Iterator_Ptr if non null, or the next non null 54 -- element in table if any. 55 56 --------- 57 -- Get -- 58 --------- 59 60 function Get (T : Instance; K : Key) return Elmt_Ptr is 61 Elmt : Elmt_Ptr; 62 63 begin 64 if T = null then 65 return Null_Ptr; 66 end if; 67 68 Elmt := T.Table (Hash (K)); 69 70 loop 71 if Elmt = Null_Ptr then 72 return Null_Ptr; 73 74 elsif Equal (Get_Key (Elmt), K) then 75 return Elmt; 76 77 else 78 Elmt := Next (Elmt); 79 end if; 80 end loop; 81 end Get; 82 83 --------------- 84 -- Get_First -- 85 --------------- 86 87 function Get_First (T : Instance) return Elmt_Ptr is 88 begin 89 if T = null then 90 return Null_Ptr; 91 end if; 92 93 T.Iterator_Started := True; 94 T.Iterator_Index := T.Table'First; 95 T.Iterator_Ptr := T.Table (T.Iterator_Index); 96 return Get_Non_Null (T); 97 end Get_First; 98 99 -------------- 100 -- Get_Next -- 101 -------------- 102 103 function Get_Next (T : Instance) return Elmt_Ptr is 104 begin 105 if T = null or else not T.Iterator_Started then 106 return Null_Ptr; 107 end if; 108 109 T.Iterator_Ptr := Next (T.Iterator_Ptr); 110 return Get_Non_Null (T); 111 end Get_Next; 112 113 ------------------ 114 -- Get_Non_Null -- 115 ------------------ 116 117 function Get_Non_Null (T : Instance) return Elmt_Ptr is 118 begin 119 if T = null then 120 return Null_Ptr; 121 end if; 122 123 while T.Iterator_Ptr = Null_Ptr loop 124 if T.Iterator_Index = T.Table'Last then 125 T.Iterator_Started := False; 126 return Null_Ptr; 127 end if; 128 129 T.Iterator_Index := T.Iterator_Index + 1; 130 T.Iterator_Ptr := T.Table (T.Iterator_Index); 131 end loop; 132 133 return T.Iterator_Ptr; 134 end Get_Non_Null; 135 136 ------------ 137 -- Remove -- 138 ------------ 139 140 procedure Remove (T : Instance; K : Key) is 141 Index : constant Header_Num := Hash (K); 142 Elmt : Elmt_Ptr; 143 Next_Elmt : Elmt_Ptr; 144 145 begin 146 if T = null then 147 return; 148 end if; 149 150 Elmt := T.Table (Index); 151 152 if Elmt = Null_Ptr then 153 return; 154 155 elsif Equal (Get_Key (Elmt), K) then 156 T.Table (Index) := Next (Elmt); 157 158 else 159 loop 160 Next_Elmt := Next (Elmt); 161 162 if Next_Elmt = Null_Ptr then 163 return; 164 165 elsif Equal (Get_Key (Next_Elmt), K) then 166 Set_Next (Elmt, Next (Next_Elmt)); 167 return; 168 169 else 170 Elmt := Next_Elmt; 171 end if; 172 end loop; 173 end if; 174 end Remove; 175 176 ----------- 177 -- Reset -- 178 ----------- 179 180 procedure Reset (T : in out Instance) is 181 procedure Free is 182 new Ada.Unchecked_Deallocation (Instance_Data, Instance); 183 184 begin 185 if T = null then 186 return; 187 end if; 188 189 for J in T.Table'Range loop 190 T.Table (J) := Null_Ptr; 191 end loop; 192 193 Free (T); 194 end Reset; 195 196 --------- 197 -- Set -- 198 --------- 199 200 procedure Set (T : in out Instance; E : Elmt_Ptr) is 201 Index : Header_Num; 202 203 begin 204 if T = null then 205 T := new Instance_Data; 206 end if; 207 208 Index := Hash (Get_Key (E)); 209 Set_Next (E, T.Table (Index)); 210 T.Table (Index) := E; 211 end Set; 212 213 end Static_HTable; 214 215 ------------------- 216 -- Simple_HTable -- 217 ------------------- 218 219 package body Simple_HTable is 220 procedure Free is new 221 Ada.Unchecked_Deallocation (Element_Wrapper, Elmt_Ptr); 222 223 --------- 224 -- Get -- 225 --------- 226 227 function Get (T : Instance; K : Key) return Element is 228 Tmp : Elmt_Ptr; 229 230 begin 231 if T = Nil then 232 return No_Element; 233 end if; 234 235 Tmp := Tab.Get (Tab.Instance (T), K); 236 237 if Tmp = null then 238 return No_Element; 239 else 240 return Tmp.E; 241 end if; 242 end Get; 243 244 --------------- 245 -- Get_First -- 246 --------------- 247 248 function Get_First (T : Instance) return Element is 249 Tmp : constant Elmt_Ptr := Tab.Get_First (Tab.Instance (T)); 250 251 begin 252 if Tmp = null then 253 return No_Element; 254 else 255 return Tmp.E; 256 end if; 257 end Get_First; 258 259 ------------- 260 -- Get_Key -- 261 ------------- 262 263 function Get_Key (E : Elmt_Ptr) return Key is 264 begin 265 return E.K; 266 end Get_Key; 267 268 -------------- 269 -- Get_Next -- 270 -------------- 271 272 function Get_Next (T : Instance) return Element is 273 Tmp : constant Elmt_Ptr := Tab.Get_Next (Tab.Instance (T)); 274 begin 275 if Tmp = null then 276 return No_Element; 277 else 278 return Tmp.E; 279 end if; 280 end Get_Next; 281 282 ---------- 283 -- Next -- 284 ---------- 285 286 function Next (E : Elmt_Ptr) return Elmt_Ptr is 287 begin 288 return E.Next; 289 end Next; 290 291 ------------ 292 -- Remove -- 293 ------------ 294 295 procedure Remove (T : Instance; K : Key) is 296 Tmp : Elmt_Ptr; 297 298 begin 299 Tmp := Tab.Get (Tab.Instance (T), K); 300 301 if Tmp /= null then 302 Tab.Remove (Tab.Instance (T), K); 303 Free (Tmp); 304 end if; 305 end Remove; 306 307 ----------- 308 -- Reset -- 309 ----------- 310 311 procedure Reset (T : in out Instance) is 312 E1, E2 : Elmt_Ptr; 313 314 begin 315 E1 := Tab.Get_First (Tab.Instance (T)); 316 while E1 /= null loop 317 E2 := Tab.Get_Next (Tab.Instance (T)); 318 Free (E1); 319 E1 := E2; 320 end loop; 321 322 Tab.Reset (Tab.Instance (T)); 323 end Reset; 324 325 --------- 326 -- Set -- 327 --------- 328 329 procedure Set (T : in out Instance; K : Key; E : Element) is 330 Tmp : constant Elmt_Ptr := Tab.Get (Tab.Instance (T), K); 331 begin 332 if Tmp = null then 333 Tab.Set (Tab.Instance (T), new Element_Wrapper'(K, E, null)); 334 else 335 Tmp.E := E; 336 end if; 337 end Set; 338 339 -------------- 340 -- Set_Next -- 341 -------------- 342 343 procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is 344 begin 345 E.Next := Next; 346 end Set_Next; 347 348 end Simple_HTable; 349 350 ------------------------ 351 -- Load_Factor_HTable -- 352 ------------------------ 353 354 package body Load_Factor_HTable is 355 356 Min_Size_Increase : constant := 5; 357 -- The minimum increase expressed as number of buckets. This value is 358 -- used to determine the new size of small tables and/or small growth 359 -- percentages. 360 361 procedure Attach 362 (Elmt : not null Element_Ptr; 363 Chain : not null Element_Ptr); 364 -- Prepend an element to a bucket chain. Elmt is inserted after the 365 -- dummy head of Chain. 366 367 function Create_Buckets (Size : Positive) return Buckets_Array_Ptr; 368 -- Allocate and initialize a new set of buckets. The buckets are created 369 -- in the range Range_Type'First .. Range_Type'First + Size - 1. 370 371 procedure Detach (Elmt : not null Element_Ptr); 372 -- Remove an element from an arbitrary bucket chain 373 374 function Find 375 (Key : Key_Type; 376 Chain : not null Element_Ptr) return Element_Ptr; 377 -- Try to locate the element which contains a particular key within a 378 -- bucket chain. If no such element exists, return No_Element. 379 380 procedure Free is 381 new Ada.Unchecked_Deallocation (Buckets_Array, Buckets_Array_Ptr); 382 383 procedure Free is 384 new Ada.Unchecked_Deallocation (Element, Element_Ptr); 385 386 function Is_Empty_Chain (Chain : not null Element_Ptr) return Boolean; 387 -- Determine whether a bucket chain contains only one element, namely 388 -- the dummy head. 389 390 ------------ 391 -- Attach -- 392 ------------ 393 394 procedure Attach 395 (Elmt : not null Element_Ptr; 396 Chain : not null Element_Ptr) 397 is 398 begin 399 Chain.Next.Prev := Elmt; 400 Elmt.Next := Chain.Next; 401 Chain.Next := Elmt; 402 Elmt.Prev := Chain; 403 end Attach; 404 405 -------------------- 406 -- Create_Buckets -- 407 -------------------- 408 409 function Create_Buckets (Size : Positive) return Buckets_Array_Ptr is 410 Low_Bound : constant Range_Type := Range_Type'First; 411 Buckets : Buckets_Array_Ptr; 412 413 begin 414 Buckets := 415 new Buckets_Array (Low_Bound .. Low_Bound + Range_Type (Size) - 1); 416 417 -- Ensure that the dummy head of each bucket chain points to itself 418 -- in both directions. 419 420 for Index in Buckets'Range loop 421 declare 422 Bucket : Element renames Buckets (Index); 423 424 begin 425 Bucket.Prev := Bucket'Unchecked_Access; 426 Bucket.Next := Bucket'Unchecked_Access; 427 end; 428 end loop; 429 430 return Buckets; 431 end Create_Buckets; 432 433 ------------------ 434 -- Current_Size -- 435 ------------------ 436 437 function Current_Size (T : Table) return Positive is 438 begin 439 -- The table should have been properly initialized during object 440 -- elaboration. 441 442 if T.Buckets = null then 443 raise Program_Error; 444 445 -- The size of the table is determined by the number of buckets 446 447 else 448 return T.Buckets'Length; 449 end if; 450 end Current_Size; 451 452 ------------ 453 -- Detach -- 454 ------------ 455 456 procedure Detach (Elmt : not null Element_Ptr) is 457 begin 458 if Elmt.Prev /= null and Elmt.Next /= null then 459 Elmt.Prev.Next := Elmt.Next; 460 Elmt.Next.Prev := Elmt.Prev; 461 Elmt.Prev := null; 462 Elmt.Next := null; 463 end if; 464 end Detach; 465 466 -------------- 467 -- Finalize -- 468 -------------- 469 470 procedure Finalize (T : in out Table) is 471 Bucket : Element_Ptr; 472 Elmt : Element_Ptr; 473 474 begin 475 -- Inspect the buckets and deallocate bucket chains 476 477 for Index in T.Buckets'Range loop 478 Bucket := T.Buckets (Index)'Unchecked_Access; 479 480 -- The current bucket chain contains an element other than the 481 -- dummy head. 482 483 while not Is_Empty_Chain (Bucket) loop 484 485 -- Skip the dummy head, remove and deallocate the element 486 487 Elmt := Bucket.Next; 488 Detach (Elmt); 489 Free (Elmt); 490 end loop; 491 end loop; 492 493 -- Deallocate the buckets 494 495 Free (T.Buckets); 496 end Finalize; 497 498 ---------- 499 -- Find -- 500 ---------- 501 502 function Find 503 (Key : Key_Type; 504 Chain : not null Element_Ptr) return Element_Ptr 505 is 506 Elmt : Element_Ptr; 507 508 begin 509 -- Skip the dummy head, inspect the bucket chain for an element whose 510 -- key matches the requested key. Since each bucket chain is circular 511 -- the search must stop once the dummy head is encountered. 512 513 Elmt := Chain.Next; 514 while Elmt /= Chain loop 515 if Equal (Elmt.Key, Key) then 516 return Elmt; 517 end if; 518 519 Elmt := Elmt.Next; 520 end loop; 521 522 return No_Element; 523 end Find; 524 525 --------- 526 -- Get -- 527 --------- 528 529 function Get (T : Table; Key : Key_Type) return Value_Type is 530 Bucket : Element_Ptr; 531 Elmt : Element_Ptr; 532 533 begin 534 -- Obtain the bucket chain where the (key, value) pair should reside 535 -- by calculating the proper hash location. 536 537 Bucket := T.Buckets (Hash (Key, Current_Size (T)))'Unchecked_Access; 538 539 -- Try to find an element whose key matches the requested key 540 541 Elmt := Find (Key, Bucket); 542 543 -- The hash table does not contain a matching (key, value) pair 544 545 if Elmt = No_Element then 546 return No_Value; 547 else 548 return Elmt.Val; 549 end if; 550 end Get; 551 552 ---------------- 553 -- Initialize -- 554 ---------------- 555 556 procedure Initialize (T : in out Table) is 557 begin 558 pragma Assert (T.Buckets = null); 559 560 T.Buckets := Create_Buckets (Initial_Size); 561 T.Element_Count := 0; 562 end Initialize; 563 564 -------------------- 565 -- Is_Empty_Chain -- 566 -------------------- 567 568 function Is_Empty_Chain (Chain : not null Element_Ptr) return Boolean is 569 begin 570 return Chain.Next = Chain and Chain.Prev = Chain; 571 end Is_Empty_Chain; 572 573 ------------ 574 -- Remove -- 575 ------------ 576 577 procedure Remove (T : in out Table; Key : Key_Type) is 578 Bucket : Element_Ptr; 579 Elmt : Element_Ptr; 580 581 begin 582 -- Obtain the bucket chain where the (key, value) pair should reside 583 -- by calculating the proper hash location. 584 585 Bucket := T.Buckets (Hash (Key, Current_Size (T)))'Unchecked_Access; 586 587 -- Try to find an element whose key matches the requested key 588 589 Elmt := Find (Key, Bucket); 590 591 -- Remove and deallocate the (key, value) pair 592 593 if Elmt /= No_Element then 594 Detach (Elmt); 595 Free (Elmt); 596 end if; 597 end Remove; 598 599 --------- 600 -- Set -- 601 --------- 602 603 procedure Set 604 (T : in out Table; 605 Key : Key_Type; 606 Val : Value_Type) 607 is 608 Curr_Size : constant Positive := Current_Size (T); 609 610 procedure Grow; 611 -- Grow the table to a new size according to the desired percentage 612 -- and relocate all existing elements to the new buckets. 613 614 ---------- 615 -- Grow -- 616 ---------- 617 618 procedure Grow is 619 Buckets : Buckets_Array_Ptr; 620 Elmt : Element_Ptr; 621 Hash_Loc : Range_Type; 622 Old_Bucket : Element_Ptr; 623 Old_Buckets : Buckets_Array_Ptr := T.Buckets; 624 Size : Positive; 625 626 begin 627 -- Calculate the new size and allocate a new set of buckets. Note 628 -- that a table with a small size or a small growth percentage may 629 -- not always grow (for example, 10 buckets and 3% increase). In 630 -- that case, enforce a minimum increase. 631 632 Size := 633 Positive'Max (Curr_Size * ((100 + Growth_Percentage) / 100), 634 Min_Size_Increase); 635 Buckets := Create_Buckets (Size); 636 637 -- Inspect the old buckets and transfer all elements by rehashing 638 -- all (key, value) pairs in the new buckets. 639 640 for Index in Old_Buckets'Range loop 641 Old_Bucket := Old_Buckets (Index)'Unchecked_Access; 642 643 -- The current bucket chain contains an element other than the 644 -- dummy head. 645 646 while not Is_Empty_Chain (Old_Bucket) loop 647 648 -- Skip the dummy head and find the new hash location 649 650 Elmt := Old_Bucket.Next; 651 Hash_Loc := Hash (Elmt.Key, Size); 652 653 -- Remove the element from the old buckets and insert it 654 -- into the new buckets. Note that there is no need to check 655 -- for duplicates because the hash table did not have any to 656 -- begin with. 657 658 Detach (Elmt); 659 Attach 660 (Elmt => Elmt, 661 Chain => Buckets (Hash_Loc)'Unchecked_Access); 662 end loop; 663 end loop; 664 665 -- Associate the new buckets with the table and reclaim the 666 -- storage occupied by the old buckets. 667 668 T.Buckets := Buckets; 669 670 Free (Old_Buckets); 671 end Grow; 672 673 -- Local variables 674 675 subtype LLF is Long_Long_Float; 676 677 Count : Natural renames T.Element_Count; 678 Bucket : Element_Ptr; 679 Hash_Loc : Range_Type; 680 681 -- Start of processing for Set 682 683 begin 684 -- Find the bucket where the (key, value) pair should be inserted by 685 -- computing the proper hash location. 686 687 Hash_Loc := Hash (Key, Curr_Size); 688 Bucket := T.Buckets (Hash_Loc)'Unchecked_Access; 689 690 -- Ensure that the key is not already present in the bucket in order 691 -- to avoid duplicates. 692 693 if Find (Key, Bucket) = No_Element then 694 Attach 695 (Elmt => new Element'(Key, Val, null, null), 696 Chain => Bucket); 697 Count := Count + 1; 698 699 -- Multiple insertions may cause long bucket chains and decrease 700 -- the performance of basic operations. If this is the case, grow 701 -- the table and rehash all existing elements. 702 703 if (LLF (Count) / LLF (Curr_Size)) > LLF (Load_Factor) then 704 Grow; 705 end if; 706 end if; 707 end Set; 708 end Load_Factor_HTable; 709 710end GNAT.Dynamic_HTables; 711