1------------------------------------------------------------------------------ 2-- -- 3-- GNAT LIBRARY COMPONENTS -- 4-- -- 5-- ADA.CONTAINERS.INDEFINITE_HASHED_SETS -- 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 Ada.Unchecked_Deallocation; 31 32with Ada.Containers.Hash_Tables.Generic_Operations; 33pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations); 34 35with Ada.Containers.Hash_Tables.Generic_Keys; 36pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys); 37 38with Ada.Containers.Helpers; use Ada.Containers.Helpers; 39 40with Ada.Containers.Prime_Numbers; 41 42with System; use type System.Address; 43 44package body Ada.Containers.Indefinite_Hashed_Sets is 45 46 pragma Warnings (Off, "variable ""Busy*"" is not referenced"); 47 pragma Warnings (Off, "variable ""Lock*"" is not referenced"); 48 -- See comment in Ada.Containers.Helpers 49 50 ----------------------- 51 -- Local Subprograms -- 52 ----------------------- 53 54 procedure Assign (Node : Node_Access; Item : Element_Type); 55 pragma Inline (Assign); 56 57 function Copy_Node (Source : Node_Access) return Node_Access; 58 pragma Inline (Copy_Node); 59 60 function Equivalent_Keys 61 (Key : Element_Type; 62 Node : Node_Access) return Boolean; 63 pragma Inline (Equivalent_Keys); 64 65 function Find_Equal_Key 66 (R_HT : Hash_Table_Type; 67 L_Node : Node_Access) return Boolean; 68 69 function Find_Equivalent_Key 70 (R_HT : Hash_Table_Type; 71 L_Node : Node_Access) return Boolean; 72 73 procedure Free (X : in out Node_Access); 74 75 function Hash_Node (Node : Node_Access) return Hash_Type; 76 pragma Inline (Hash_Node); 77 78 procedure Insert 79 (HT : in out Hash_Table_Type; 80 New_Item : Element_Type; 81 Node : out Node_Access; 82 Inserted : out Boolean); 83 84 function Is_In 85 (HT : aliased in out Hash_Table_Type; 86 Key : Node_Access) return Boolean; 87 pragma Inline (Is_In); 88 89 function Next (Node : Node_Access) return Node_Access; 90 pragma Inline (Next); 91 92 function Read_Node (Stream : not null access Root_Stream_Type'Class) 93 return Node_Access; 94 pragma Inline (Read_Node); 95 96 procedure Set_Next (Node : Node_Access; Next : Node_Access); 97 pragma Inline (Set_Next); 98 99 function Vet (Position : Cursor) return Boolean; 100 101 procedure Write_Node 102 (Stream : not null access Root_Stream_Type'Class; 103 Node : Node_Access); 104 pragma Inline (Write_Node); 105 106 -------------------------- 107 -- Local Instantiations -- 108 -------------------------- 109 110 procedure Free_Element is 111 new Ada.Unchecked_Deallocation (Element_Type, Element_Access); 112 113 package HT_Ops is new Hash_Tables.Generic_Operations 114 (HT_Types => HT_Types, 115 Hash_Node => Hash_Node, 116 Next => Next, 117 Set_Next => Set_Next, 118 Copy_Node => Copy_Node, 119 Free => Free); 120 121 package Element_Keys is new Hash_Tables.Generic_Keys 122 (HT_Types => HT_Types, 123 Next => Next, 124 Set_Next => Set_Next, 125 Key_Type => Element_Type, 126 Hash => Hash, 127 Equivalent_Keys => Equivalent_Keys); 128 129 function Is_Equal is 130 new HT_Ops.Generic_Equal (Find_Equal_Key); 131 132 function Is_Equivalent is 133 new HT_Ops.Generic_Equal (Find_Equivalent_Key); 134 135 procedure Read_Nodes is 136 new HT_Ops.Generic_Read (Read_Node); 137 138 procedure Replace_Element is 139 new Element_Keys.Generic_Replace_Element (Hash_Node, Assign); 140 141 procedure Write_Nodes is 142 new HT_Ops.Generic_Write (Write_Node); 143 144 --------- 145 -- "=" -- 146 --------- 147 148 function "=" (Left, Right : Set) return Boolean is 149 begin 150 return Is_Equal (Left.HT, Right.HT); 151 end "="; 152 153 ------------ 154 -- Adjust -- 155 ------------ 156 157 procedure Adjust (Container : in out Set) is 158 begin 159 HT_Ops.Adjust (Container.HT); 160 end Adjust; 161 162 ------------ 163 -- Assign -- 164 ------------ 165 166 procedure Assign (Node : Node_Access; Item : Element_Type) is 167 X : Element_Access := Node.Element; 168 169 -- The element allocator may need an accessibility check in the case the 170 -- actual type is class-wide or has access discriminants (RM 4.8(10.1) 171 -- and AI12-0035). 172 173 pragma Unsuppress (Accessibility_Check); 174 175 begin 176 Node.Element := new Element_Type'(Item); 177 Free_Element (X); 178 end Assign; 179 180 procedure Assign (Target : in out Set; Source : Set) is 181 begin 182 if Target'Address = Source'Address then 183 return; 184 else 185 Target.Clear; 186 Target.Union (Source); 187 end if; 188 end Assign; 189 190 -------------- 191 -- Capacity -- 192 -------------- 193 194 function Capacity (Container : Set) return Count_Type is 195 begin 196 return HT_Ops.Capacity (Container.HT); 197 end Capacity; 198 199 ----------- 200 -- Clear -- 201 ----------- 202 203 procedure Clear (Container : in out Set) is 204 begin 205 HT_Ops.Clear (Container.HT); 206 end Clear; 207 208 ------------------------ 209 -- Constant_Reference -- 210 ------------------------ 211 212 function Constant_Reference 213 (Container : aliased Set; 214 Position : Cursor) return Constant_Reference_Type 215 is 216 begin 217 if Checks and then Position.Container = null then 218 raise Constraint_Error with "Position cursor has no element"; 219 end if; 220 221 if Checks and then Position.Container /= Container'Unrestricted_Access 222 then 223 raise Program_Error with 224 "Position cursor designates wrong container"; 225 end if; 226 227 if Checks and then Position.Node.Element = null then 228 raise Program_Error with "Node has no element"; 229 end if; 230 231 pragma Assert (Vet (Position), "bad cursor in Constant_Reference"); 232 233 declare 234 HT : Hash_Table_Type renames Position.Container.all.HT; 235 TC : constant Tamper_Counts_Access := 236 HT.TC'Unrestricted_Access; 237 begin 238 return R : constant Constant_Reference_Type := 239 (Element => Position.Node.Element.all'Access, 240 Control => (Controlled with TC)) 241 do 242 Lock (TC.all); 243 end return; 244 end; 245 end Constant_Reference; 246 247 -------------- 248 -- Contains -- 249 -------------- 250 251 function Contains (Container : Set; Item : Element_Type) return Boolean is 252 begin 253 return Find (Container, Item) /= No_Element; 254 end Contains; 255 256 ---------- 257 -- Copy -- 258 ---------- 259 260 function Copy 261 (Source : Set; 262 Capacity : Count_Type := 0) return Set 263 is 264 C : Count_Type; 265 266 begin 267 if Capacity = 0 then 268 C := Source.Length; 269 270 elsif Capacity >= Source.Length then 271 C := Capacity; 272 273 elsif Checks then 274 raise Capacity_Error 275 with "Requested capacity is less than Source length"; 276 end if; 277 278 return Target : Set do 279 Target.Reserve_Capacity (C); 280 Target.Assign (Source); 281 end return; 282 end Copy; 283 284 --------------- 285 -- Copy_Node -- 286 --------------- 287 288 function Copy_Node (Source : Node_Access) return Node_Access is 289 E : Element_Access := new Element_Type'(Source.Element.all); 290 begin 291 return new Node_Type'(Element => E, Next => null); 292 exception 293 when others => 294 Free_Element (E); 295 raise; 296 end Copy_Node; 297 298 ------------ 299 -- Delete -- 300 ------------ 301 302 procedure Delete 303 (Container : in out Set; 304 Item : Element_Type) 305 is 306 X : Node_Access; 307 308 begin 309 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); 310 311 if Checks and then X = null then 312 raise Constraint_Error with "attempt to delete element not in set"; 313 end if; 314 315 Free (X); 316 end Delete; 317 318 procedure Delete 319 (Container : in out Set; 320 Position : in out Cursor) 321 is 322 begin 323 if Checks and then Position.Node = null then 324 raise Constraint_Error with "Position cursor equals No_Element"; 325 end if; 326 327 if Checks and then Position.Node.Element = null then 328 raise Program_Error with "Position cursor is bad"; 329 end if; 330 331 if Checks and then Position.Container /= Container'Unrestricted_Access 332 then 333 raise Program_Error with "Position cursor designates wrong set"; 334 end if; 335 336 TC_Check (Container.HT.TC); 337 338 pragma Assert (Vet (Position), "Position cursor is bad"); 339 340 HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node); 341 342 Free (Position.Node); 343 Position.Container := null; 344 end Delete; 345 346 ---------------- 347 -- Difference -- 348 ---------------- 349 350 procedure Difference 351 (Target : in out Set; 352 Source : Set) 353 is 354 Src_HT : Hash_Table_Type renames Source'Unrestricted_Access.HT; 355 Tgt_Node : Node_Access; 356 357 begin 358 if Target'Address = Source'Address then 359 Clear (Target); 360 return; 361 end if; 362 363 if Src_HT.Length = 0 then 364 return; 365 end if; 366 367 TC_Check (Target.HT.TC); 368 369 if Src_HT.Length < Target.HT.Length then 370 declare 371 Src_Node : Node_Access; 372 373 begin 374 Src_Node := HT_Ops.First (Src_HT); 375 while Src_Node /= null loop 376 Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element.all); 377 378 if Tgt_Node /= null then 379 HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node); 380 Free (Tgt_Node); 381 end if; 382 383 Src_Node := HT_Ops.Next (Src_HT, Src_Node); 384 end loop; 385 end; 386 387 else 388 Tgt_Node := HT_Ops.First (Target.HT); 389 while Tgt_Node /= null loop 390 if Is_In (Src_HT, Tgt_Node) then 391 declare 392 X : Node_Access := Tgt_Node; 393 begin 394 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); 395 HT_Ops.Delete_Node_Sans_Free (Target.HT, X); 396 Free (X); 397 end; 398 399 else 400 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); 401 end if; 402 end loop; 403 end if; 404 end Difference; 405 406 function Difference (Left, Right : Set) return Set is 407 Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; 408 Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; 409 Buckets : HT_Types.Buckets_Access; 410 Length : Count_Type; 411 412 begin 413 if Left'Address = Right'Address then 414 return Empty_Set; 415 end if; 416 417 if Left.Length = 0 then 418 return Empty_Set; 419 end if; 420 421 if Right.Length = 0 then 422 return Left; 423 end if; 424 425 declare 426 Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length); 427 begin 428 Buckets := HT_Ops.New_Buckets (Length => Size); 429 end; 430 431 Length := 0; 432 433 Iterate_Left : declare 434 procedure Process (L_Node : Node_Access); 435 436 procedure Iterate is 437 new HT_Ops.Generic_Iteration (Process); 438 439 ------------- 440 -- Process -- 441 ------------- 442 443 procedure Process (L_Node : Node_Access) is 444 begin 445 if not Is_In (Right_HT, L_Node) then 446 declare 447 -- Per AI05-0022, the container implementation is required 448 -- to detect element tampering by a generic actual 449 -- subprogram, hence the use of Checked_Index instead of a 450 -- simple invocation of generic formal Hash. 451 452 Indx : constant Hash_Type := 453 HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node); 454 455 Bucket : Node_Access renames Buckets (Indx); 456 Src : Element_Type renames L_Node.Element.all; 457 Tgt : Element_Access := new Element_Type'(Src); 458 459 begin 460 Bucket := new Node_Type'(Tgt, Bucket); 461 462 exception 463 when others => 464 Free_Element (Tgt); 465 raise; 466 end; 467 468 Length := Length + 1; 469 end if; 470 end Process; 471 472 -- Start of processing for Iterate_Left 473 474 begin 475 Iterate (Left.HT); 476 477 exception 478 when others => 479 HT_Ops.Free_Hash_Table (Buckets); 480 raise; 481 end Iterate_Left; 482 483 return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); 484 end Difference; 485 486 ------------- 487 -- Element -- 488 ------------- 489 490 function Element (Position : Cursor) return Element_Type is 491 begin 492 if Checks and then Position.Node = null then 493 raise Constraint_Error with "Position cursor of equals No_Element"; 494 end if; 495 496 if Checks and then Position.Node.Element = null then 497 -- handle dangling reference 498 raise Program_Error with "Position cursor is bad"; 499 end if; 500 501 pragma Assert (Vet (Position), "bad cursor in function Element"); 502 503 return Position.Node.Element.all; 504 end Element; 505 506 --------------------- 507 -- Equivalent_Sets -- 508 --------------------- 509 510 function Equivalent_Sets (Left, Right : Set) return Boolean is 511 begin 512 return Is_Equivalent (Left.HT, Right.HT); 513 end Equivalent_Sets; 514 515 ------------------------- 516 -- Equivalent_Elements -- 517 ------------------------- 518 519 function Equivalent_Elements (Left, Right : Cursor) return Boolean is 520 begin 521 if Checks and then Left.Node = null then 522 raise Constraint_Error with 523 "Left cursor of Equivalent_Elements equals No_Element"; 524 end if; 525 526 if Checks and then Right.Node = null then 527 raise Constraint_Error with 528 "Right cursor of Equivalent_Elements equals No_Element"; 529 end if; 530 531 if Checks and then Left.Node.Element = null then 532 raise Program_Error with 533 "Left cursor of Equivalent_Elements is bad"; 534 end if; 535 536 if Checks and then Right.Node.Element = null then 537 raise Program_Error with 538 "Right cursor of Equivalent_Elements is bad"; 539 end if; 540 541 pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements"); 542 pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements"); 543 544 -- AI05-0022 requires that a container implementation detect element 545 -- tampering by a generic actual subprogram. However, the following case 546 -- falls outside the scope of that AI. Randy Brukardt explained on the 547 -- ARG list on 2013/02/07 that: 548 549 -- (Begin Quote): 550 -- But for an operation like "<" [the ordered set analog of 551 -- Equivalent_Elements], there is no need to "dereference" a cursor 552 -- after the call to the generic formal parameter function, so nothing 553 -- bad could happen if tampering is undetected. And the operation can 554 -- safely return a result without a problem even if an element is 555 -- deleted from the container. 556 -- (End Quote). 557 558 return Equivalent_Elements 559 (Left.Node.Element.all, 560 Right.Node.Element.all); 561 end Equivalent_Elements; 562 563 function Equivalent_Elements 564 (Left : Cursor; 565 Right : Element_Type) return Boolean 566 is 567 begin 568 if Checks and then Left.Node = null then 569 raise Constraint_Error with 570 "Left cursor of Equivalent_Elements equals No_Element"; 571 end if; 572 573 if Checks and then Left.Node.Element = null then 574 raise Program_Error with 575 "Left cursor of Equivalent_Elements is bad"; 576 end if; 577 578 pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements"); 579 580 return Equivalent_Elements (Left.Node.Element.all, Right); 581 end Equivalent_Elements; 582 583 function Equivalent_Elements 584 (Left : Element_Type; 585 Right : Cursor) return Boolean 586 is 587 begin 588 if Checks and then Right.Node = null then 589 raise Constraint_Error with 590 "Right cursor of Equivalent_Elements equals No_Element"; 591 end if; 592 593 if Checks and then Right.Node.Element = null then 594 raise Program_Error with 595 "Right cursor of Equivalent_Elements is bad"; 596 end if; 597 598 pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements"); 599 600 return Equivalent_Elements (Left, Right.Node.Element.all); 601 end Equivalent_Elements; 602 603 --------------------- 604 -- Equivalent_Keys -- 605 --------------------- 606 607 function Equivalent_Keys 608 (Key : Element_Type; 609 Node : Node_Access) return Boolean 610 is 611 begin 612 return Equivalent_Elements (Key, Node.Element.all); 613 end Equivalent_Keys; 614 615 ------------- 616 -- Exclude -- 617 ------------- 618 619 procedure Exclude 620 (Container : in out Set; 621 Item : Element_Type) 622 is 623 X : Node_Access; 624 begin 625 Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X); 626 Free (X); 627 end Exclude; 628 629 -------------- 630 -- Finalize -- 631 -------------- 632 633 procedure Finalize (Container : in out Set) is 634 begin 635 HT_Ops.Finalize (Container.HT); 636 end Finalize; 637 638 procedure Finalize (Object : in out Iterator) is 639 begin 640 if Object.Container /= null then 641 Unbusy (Object.Container.HT.TC); 642 end if; 643 end Finalize; 644 645 ---------- 646 -- Find -- 647 ---------- 648 649 function Find 650 (Container : Set; 651 Item : Element_Type) return Cursor 652 is 653 HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; 654 Node : constant Node_Access := Element_Keys.Find (HT, Item); 655 begin 656 return (if Node = null then No_Element 657 else Cursor'(Container'Unrestricted_Access, Node)); 658 end Find; 659 660 -------------------- 661 -- Find_Equal_Key -- 662 -------------------- 663 664 function Find_Equal_Key 665 (R_HT : Hash_Table_Type; 666 L_Node : Node_Access) return Boolean 667 is 668 R_Index : constant Hash_Type := 669 Element_Keys.Index (R_HT, L_Node.Element.all); 670 671 R_Node : Node_Access := R_HT.Buckets (R_Index); 672 673 begin 674 loop 675 if R_Node = null then 676 return False; 677 end if; 678 679 if L_Node.Element.all = R_Node.Element.all then 680 return True; 681 end if; 682 683 R_Node := Next (R_Node); 684 end loop; 685 end Find_Equal_Key; 686 687 ------------------------- 688 -- Find_Equivalent_Key -- 689 ------------------------- 690 691 function Find_Equivalent_Key 692 (R_HT : Hash_Table_Type; 693 L_Node : Node_Access) return Boolean 694 is 695 R_Index : constant Hash_Type := 696 Element_Keys.Index (R_HT, L_Node.Element.all); 697 698 R_Node : Node_Access := R_HT.Buckets (R_Index); 699 700 begin 701 loop 702 if R_Node = null then 703 return False; 704 end if; 705 706 if Equivalent_Elements (L_Node.Element.all, R_Node.Element.all) then 707 return True; 708 end if; 709 710 R_Node := Next (R_Node); 711 end loop; 712 end Find_Equivalent_Key; 713 714 ----------- 715 -- First -- 716 ----------- 717 718 function First (Container : Set) return Cursor is 719 Node : constant Node_Access := HT_Ops.First (Container.HT); 720 begin 721 return (if Node = null then No_Element 722 else Cursor'(Container'Unrestricted_Access, Node)); 723 end First; 724 725 function First (Object : Iterator) return Cursor is 726 begin 727 return Object.Container.First; 728 end First; 729 730 ---------- 731 -- Free -- 732 ---------- 733 734 procedure Free (X : in out Node_Access) is 735 procedure Deallocate is 736 new Ada.Unchecked_Deallocation (Node_Type, Node_Access); 737 738 begin 739 if X = null then 740 return; 741 end if; 742 743 X.Next := X; -- detect mischief (in Vet) 744 745 begin 746 Free_Element (X.Element); 747 748 exception 749 when others => 750 X.Element := null; 751 Deallocate (X); 752 raise; 753 end; 754 755 Deallocate (X); 756 end Free; 757 758 ------------------------ 759 -- Get_Element_Access -- 760 ------------------------ 761 762 function Get_Element_Access 763 (Position : Cursor) return not null Element_Access is 764 begin 765 return Position.Node.Element; 766 end Get_Element_Access; 767 768 ----------------- 769 -- Has_Element -- 770 ----------------- 771 772 function Has_Element (Position : Cursor) return Boolean is 773 begin 774 pragma Assert (Vet (Position), "bad cursor in Has_Element"); 775 return Position.Node /= null; 776 end Has_Element; 777 778 --------------- 779 -- Hash_Node -- 780 --------------- 781 782 function Hash_Node (Node : Node_Access) return Hash_Type is 783 begin 784 return Hash (Node.Element.all); 785 end Hash_Node; 786 787 ------------- 788 -- Include -- 789 ------------- 790 791 procedure Include 792 (Container : in out Set; 793 New_Item : Element_Type) 794 is 795 Position : Cursor; 796 Inserted : Boolean; 797 798 X : Element_Access; 799 800 begin 801 Insert (Container, New_Item, Position, Inserted); 802 803 if not Inserted then 804 TE_Check (Container.HT.TC); 805 806 X := Position.Node.Element; 807 808 declare 809 -- The element allocator may need an accessibility check in the 810 -- case the actual type is class-wide or has access discriminants 811 -- (see RM 4.8(10.1) and AI12-0035). 812 813 pragma Unsuppress (Accessibility_Check); 814 815 begin 816 Position.Node.Element := new Element_Type'(New_Item); 817 end; 818 819 Free_Element (X); 820 end if; 821 end Include; 822 823 ------------ 824 -- Insert -- 825 ------------ 826 827 procedure Insert 828 (Container : in out Set; 829 New_Item : Element_Type; 830 Position : out Cursor; 831 Inserted : out Boolean) 832 is 833 begin 834 Insert (Container.HT, New_Item, Position.Node, Inserted); 835 Position.Container := Container'Unchecked_Access; 836 end Insert; 837 838 procedure Insert 839 (Container : in out Set; 840 New_Item : Element_Type) 841 is 842 Position : Cursor; 843 pragma Unreferenced (Position); 844 845 Inserted : Boolean; 846 847 begin 848 Insert (Container, New_Item, Position, Inserted); 849 850 if Checks and then not Inserted then 851 raise Constraint_Error with 852 "attempt to insert element already in set"; 853 end if; 854 end Insert; 855 856 procedure Insert 857 (HT : in out Hash_Table_Type; 858 New_Item : Element_Type; 859 Node : out Node_Access; 860 Inserted : out Boolean) 861 is 862 function New_Node (Next : Node_Access) return Node_Access; 863 pragma Inline (New_Node); 864 865 procedure Local_Insert is 866 new Element_Keys.Generic_Conditional_Insert (New_Node); 867 868 -------------- 869 -- New_Node -- 870 -------------- 871 872 function New_Node (Next : Node_Access) return Node_Access is 873 874 -- The element allocator may need an accessibility check in the case 875 -- the actual type is class-wide or has access discriminants (see 876 -- RM 4.8(10.1) and AI12-0035). 877 878 pragma Unsuppress (Accessibility_Check); 879 880 Element : Element_Access := new Element_Type'(New_Item); 881 882 begin 883 return new Node_Type'(Element, Next); 884 885 exception 886 when others => 887 Free_Element (Element); 888 raise; 889 end New_Node; 890 891 -- Start of processing for Insert 892 893 begin 894 if HT_Ops.Capacity (HT) = 0 then 895 HT_Ops.Reserve_Capacity (HT, 1); 896 end if; 897 898 Local_Insert (HT, New_Item, Node, Inserted); 899 900 if Inserted and then HT.Length > HT_Ops.Capacity (HT) then 901 HT_Ops.Reserve_Capacity (HT, HT.Length); 902 end if; 903 end Insert; 904 905 ------------------ 906 -- Intersection -- 907 ------------------ 908 909 procedure Intersection 910 (Target : in out Set; 911 Source : Set) 912 is 913 Src_HT : Hash_Table_Type renames Source'Unrestricted_Access.HT; 914 Tgt_Node : Node_Access; 915 916 begin 917 if Target'Address = Source'Address then 918 return; 919 end if; 920 921 if Source.Length = 0 then 922 Clear (Target); 923 return; 924 end if; 925 926 TC_Check (Target.HT.TC); 927 928 Tgt_Node := HT_Ops.First (Target.HT); 929 while Tgt_Node /= null loop 930 if Is_In (Src_HT, Tgt_Node) then 931 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); 932 933 else 934 declare 935 X : Node_Access := Tgt_Node; 936 begin 937 Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node); 938 HT_Ops.Delete_Node_Sans_Free (Target.HT, X); 939 Free (X); 940 end; 941 end if; 942 end loop; 943 end Intersection; 944 945 function Intersection (Left, Right : Set) return Set is 946 Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; 947 Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; 948 Buckets : HT_Types.Buckets_Access; 949 Length : Count_Type; 950 951 begin 952 if Left'Address = Right'Address then 953 return Left; 954 end if; 955 956 Length := Count_Type'Min (Left.Length, Right.Length); 957 958 if Length = 0 then 959 return Empty_Set; 960 end if; 961 962 declare 963 Size : constant Hash_Type := Prime_Numbers.To_Prime (Length); 964 begin 965 Buckets := HT_Ops.New_Buckets (Length => Size); 966 end; 967 968 Length := 0; 969 970 Iterate_Left : declare 971 procedure Process (L_Node : Node_Access); 972 973 procedure Iterate is 974 new HT_Ops.Generic_Iteration (Process); 975 976 ------------- 977 -- Process -- 978 ------------- 979 980 procedure Process (L_Node : Node_Access) is 981 begin 982 if Is_In (Right_HT, L_Node) then 983 declare 984 -- Per AI05-0022, the container implementation is required 985 -- to detect element tampering by a generic actual 986 -- subprogram, hence the use of Checked_Index instead of a 987 -- simple invocation of generic formal Hash. 988 989 Indx : constant Hash_Type := 990 HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node); 991 992 Bucket : Node_Access renames Buckets (Indx); 993 994 Src : Element_Type renames L_Node.Element.all; 995 Tgt : Element_Access := new Element_Type'(Src); 996 997 begin 998 Bucket := new Node_Type'(Tgt, Bucket); 999 1000 exception 1001 when others => 1002 Free_Element (Tgt); 1003 raise; 1004 end; 1005 1006 Length := Length + 1; 1007 end if; 1008 end Process; 1009 1010 -- Start of processing for Iterate_Left 1011 1012 begin 1013 Iterate (Left.HT); 1014 1015 exception 1016 when others => 1017 HT_Ops.Free_Hash_Table (Buckets); 1018 raise; 1019 end Iterate_Left; 1020 1021 return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); 1022 end Intersection; 1023 1024 -------------- 1025 -- Is_Empty -- 1026 -------------- 1027 1028 function Is_Empty (Container : Set) return Boolean is 1029 begin 1030 return Container.HT.Length = 0; 1031 end Is_Empty; 1032 1033 ----------- 1034 -- Is_In -- 1035 ----------- 1036 1037 function Is_In 1038 (HT : aliased in out Hash_Table_Type; 1039 Key : Node_Access) return Boolean 1040 is 1041 begin 1042 return Element_Keys.Find (HT, Key.Element.all) /= null; 1043 end Is_In; 1044 1045 --------------- 1046 -- Is_Subset -- 1047 --------------- 1048 1049 function Is_Subset 1050 (Subset : Set; 1051 Of_Set : Set) return Boolean 1052 is 1053 Subset_HT : Hash_Table_Type renames Subset'Unrestricted_Access.HT; 1054 Of_Set_HT : Hash_Table_Type renames Of_Set'Unrestricted_Access.HT; 1055 Subset_Node : Node_Access; 1056 1057 begin 1058 if Subset'Address = Of_Set'Address then 1059 return True; 1060 end if; 1061 1062 if Subset.Length > Of_Set.Length then 1063 return False; 1064 end if; 1065 1066 Subset_Node := HT_Ops.First (Subset_HT); 1067 while Subset_Node /= null loop 1068 if not Is_In (Of_Set_HT, Subset_Node) then 1069 return False; 1070 end if; 1071 1072 Subset_Node := HT_Ops.Next (Subset_HT, Subset_Node); 1073 end loop; 1074 1075 return True; 1076 end Is_Subset; 1077 1078 ------------- 1079 -- Iterate -- 1080 ------------- 1081 1082 procedure Iterate 1083 (Container : Set; 1084 Process : not null access procedure (Position : Cursor)) 1085 is 1086 procedure Process_Node (Node : Node_Access); 1087 pragma Inline (Process_Node); 1088 1089 procedure Iterate is 1090 new HT_Ops.Generic_Iteration (Process_Node); 1091 1092 ------------------ 1093 -- Process_Node -- 1094 ------------------ 1095 1096 procedure Process_Node (Node : Node_Access) is 1097 begin 1098 Process (Cursor'(Container'Unrestricted_Access, Node)); 1099 end Process_Node; 1100 1101 Busy : With_Busy (Container.HT.TC'Unrestricted_Access); 1102 1103 -- Start of processing for Iterate 1104 1105 begin 1106 Iterate (Container.HT); 1107 end Iterate; 1108 1109 function Iterate (Container : Set) 1110 return Set_Iterator_Interfaces.Forward_Iterator'Class 1111 is 1112 begin 1113 return It : constant Iterator := 1114 Iterator'(Limited_Controlled with 1115 Container => Container'Unrestricted_Access) 1116 do 1117 Busy (Container.HT.TC'Unrestricted_Access.all); 1118 end return; 1119 end Iterate; 1120 1121 ------------ 1122 -- Length -- 1123 ------------ 1124 1125 function Length (Container : Set) return Count_Type is 1126 begin 1127 return Container.HT.Length; 1128 end Length; 1129 1130 ---------- 1131 -- Move -- 1132 ---------- 1133 1134 procedure Move (Target : in out Set; Source : in out Set) is 1135 begin 1136 HT_Ops.Move (Target => Target.HT, Source => Source.HT); 1137 end Move; 1138 1139 ---------- 1140 -- Next -- 1141 ---------- 1142 1143 function Next (Node : Node_Access) return Node_Access is 1144 begin 1145 return Node.Next; 1146 end Next; 1147 1148 function Next (Position : Cursor) return Cursor is 1149 begin 1150 if Position.Node = null then 1151 return No_Element; 1152 end if; 1153 1154 if Checks and then Position.Node.Element = null then 1155 raise Program_Error with "bad cursor in Next"; 1156 end if; 1157 1158 pragma Assert (Vet (Position), "bad cursor in Next"); 1159 1160 declare 1161 HT : Hash_Table_Type renames Position.Container.HT; 1162 Node : constant Node_Access := HT_Ops.Next (HT, Position.Node); 1163 begin 1164 return (if Node = null then No_Element 1165 else Cursor'(Position.Container, Node)); 1166 end; 1167 end Next; 1168 1169 procedure Next (Position : in out Cursor) is 1170 begin 1171 Position := Next (Position); 1172 end Next; 1173 1174 function Next 1175 (Object : Iterator; 1176 Position : Cursor) return Cursor 1177 is 1178 begin 1179 if Position.Container = null then 1180 return No_Element; 1181 end if; 1182 1183 if Checks and then Position.Container /= Object.Container then 1184 raise Program_Error with 1185 "Position cursor of Next designates wrong set"; 1186 end if; 1187 1188 return Next (Position); 1189 end Next; 1190 1191 ------------- 1192 -- Overlap -- 1193 ------------- 1194 1195 function Overlap (Left, Right : Set) return Boolean is 1196 Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; 1197 Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; 1198 Left_Node : Node_Access; 1199 1200 begin 1201 if Right.Length = 0 then 1202 return False; 1203 end if; 1204 1205 if Left'Address = Right'Address then 1206 return True; 1207 end if; 1208 1209 Left_Node := HT_Ops.First (Left_HT); 1210 while Left_Node /= null loop 1211 if Is_In (Right_HT, Left_Node) then 1212 return True; 1213 end if; 1214 1215 Left_Node := HT_Ops.Next (Left_HT, Left_Node); 1216 end loop; 1217 1218 return False; 1219 end Overlap; 1220 1221 ---------------------- 1222 -- Pseudo_Reference -- 1223 ---------------------- 1224 1225 function Pseudo_Reference 1226 (Container : aliased Set'Class) return Reference_Control_Type 1227 is 1228 TC : constant Tamper_Counts_Access := 1229 Container.HT.TC'Unrestricted_Access; 1230 begin 1231 return R : constant Reference_Control_Type := (Controlled with TC) do 1232 Lock (TC.all); 1233 end return; 1234 end Pseudo_Reference; 1235 1236 ------------------- 1237 -- Query_Element -- 1238 ------------------- 1239 1240 procedure Query_Element 1241 (Position : Cursor; 1242 Process : not null access procedure (Element : Element_Type)) 1243 is 1244 begin 1245 if Checks and then Position.Node = null then 1246 raise Constraint_Error with 1247 "Position cursor of Query_Element equals No_Element"; 1248 end if; 1249 1250 if Checks and then Position.Node.Element = null then 1251 raise Program_Error with "bad cursor in Query_Element"; 1252 end if; 1253 1254 pragma Assert (Vet (Position), "bad cursor in Query_Element"); 1255 1256 declare 1257 HT : Hash_Table_Type renames 1258 Position.Container'Unrestricted_Access.all.HT; 1259 Lock : With_Lock (HT.TC'Unrestricted_Access); 1260 begin 1261 Process (Position.Node.Element.all); 1262 end; 1263 end Query_Element; 1264 1265 ---------- 1266 -- Read -- 1267 ---------- 1268 1269 procedure Read 1270 (Stream : not null access Root_Stream_Type'Class; 1271 Container : out Set) 1272 is 1273 begin 1274 Read_Nodes (Stream, Container.HT); 1275 end Read; 1276 1277 procedure Read 1278 (Stream : not null access Root_Stream_Type'Class; 1279 Item : out Cursor) 1280 is 1281 begin 1282 raise Program_Error with "attempt to stream set cursor"; 1283 end Read; 1284 1285 procedure Read 1286 (Stream : not null access Root_Stream_Type'Class; 1287 Item : out Constant_Reference_Type) 1288 is 1289 begin 1290 raise Program_Error with "attempt to stream reference"; 1291 end Read; 1292 1293 --------------- 1294 -- Read_Node -- 1295 --------------- 1296 1297 function Read_Node 1298 (Stream : not null access Root_Stream_Type'Class) return Node_Access 1299 is 1300 X : Element_Access := new Element_Type'(Element_Type'Input (Stream)); 1301 begin 1302 return new Node_Type'(X, null); 1303 exception 1304 when others => 1305 Free_Element (X); 1306 raise; 1307 end Read_Node; 1308 1309 ------------- 1310 -- Replace -- 1311 ------------- 1312 1313 procedure Replace 1314 (Container : in out Set; 1315 New_Item : Element_Type) 1316 is 1317 Node : constant Node_Access := 1318 Element_Keys.Find (Container.HT, New_Item); 1319 1320 X : Element_Access; 1321 pragma Warnings (Off, X); 1322 1323 begin 1324 if Checks and then Node = null then 1325 raise Constraint_Error with 1326 "attempt to replace element not in set"; 1327 end if; 1328 1329 TE_Check (Container.HT.TC); 1330 1331 X := Node.Element; 1332 1333 declare 1334 -- The element allocator may need an accessibility check in the case 1335 -- the actual type is class-wide or has access discriminants (see 1336 -- RM 4.8(10.1) and AI12-0035). 1337 1338 pragma Unsuppress (Accessibility_Check); 1339 1340 begin 1341 Node.Element := new Element_Type'(New_Item); 1342 end; 1343 1344 Free_Element (X); 1345 end Replace; 1346 1347 --------------------- 1348 -- Replace_Element -- 1349 --------------------- 1350 1351 procedure Replace_Element 1352 (Container : in out Set; 1353 Position : Cursor; 1354 New_Item : Element_Type) 1355 is 1356 begin 1357 if Checks and then Position.Node = null then 1358 raise Constraint_Error with "Position cursor equals No_Element"; 1359 end if; 1360 1361 if Checks and then Position.Node.Element = null then 1362 raise Program_Error with "bad cursor in Replace_Element"; 1363 end if; 1364 1365 if Checks and then Position.Container /= Container'Unrestricted_Access 1366 then 1367 raise Program_Error with 1368 "Position cursor designates wrong set"; 1369 end if; 1370 1371 pragma Assert (Vet (Position), "bad cursor in Replace_Element"); 1372 1373 Replace_Element (Container.HT, Position.Node, New_Item); 1374 end Replace_Element; 1375 1376 ---------------------- 1377 -- Reserve_Capacity -- 1378 ---------------------- 1379 1380 procedure Reserve_Capacity 1381 (Container : in out Set; 1382 Capacity : Count_Type) 1383 is 1384 begin 1385 HT_Ops.Reserve_Capacity (Container.HT, Capacity); 1386 end Reserve_Capacity; 1387 1388 -------------- 1389 -- Set_Next -- 1390 -------------- 1391 1392 procedure Set_Next (Node : Node_Access; Next : Node_Access) is 1393 begin 1394 Node.Next := Next; 1395 end Set_Next; 1396 1397 -------------------------- 1398 -- Symmetric_Difference -- 1399 -------------------------- 1400 1401 procedure Symmetric_Difference 1402 (Target : in out Set; 1403 Source : Set) 1404 is 1405 Tgt_HT : Hash_Table_Type renames Target.HT; 1406 Src_HT : Hash_Table_Type renames Source.HT'Unrestricted_Access.all; 1407 begin 1408 if Target'Address = Source'Address then 1409 Clear (Target); 1410 return; 1411 end if; 1412 1413 TC_Check (Tgt_HT.TC); 1414 1415 declare 1416 N : constant Count_Type := Target.Length + Source.Length; 1417 begin 1418 if N > HT_Ops.Capacity (Tgt_HT) then 1419 HT_Ops.Reserve_Capacity (Tgt_HT, N); 1420 end if; 1421 end; 1422 1423 if Target.Length = 0 then 1424 Iterate_Source_When_Empty_Target : declare 1425 procedure Process (Src_Node : Node_Access); 1426 1427 procedure Iterate is new HT_Ops.Generic_Iteration (Process); 1428 1429 ------------- 1430 -- Process -- 1431 ------------- 1432 1433 procedure Process (Src_Node : Node_Access) is 1434 E : Element_Type renames Src_Node.Element.all; 1435 B : Buckets_Type renames Tgt_HT.Buckets.all; 1436 J : constant Hash_Type := Hash (E) mod B'Length; 1437 N : Count_Type renames Tgt_HT.Length; 1438 1439 begin 1440 declare 1441 X : Element_Access := new Element_Type'(E); 1442 begin 1443 B (J) := new Node_Type'(X, B (J)); 1444 exception 1445 when others => 1446 Free_Element (X); 1447 raise; 1448 end; 1449 1450 N := N + 1; 1451 end Process; 1452 1453 -- Per AI05-0022, the container implementation is required to 1454 -- detect element tampering by a generic actual subprogram. 1455 1456 Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access); 1457 Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access); 1458 1459 -- Start of processing for Iterate_Source_When_Empty_Target 1460 1461 begin 1462 Iterate (Src_HT); 1463 end Iterate_Source_When_Empty_Target; 1464 1465 else 1466 Iterate_Source : declare 1467 procedure Process (Src_Node : Node_Access); 1468 1469 procedure Iterate is 1470 new HT_Ops.Generic_Iteration (Process); 1471 1472 ------------- 1473 -- Process -- 1474 ------------- 1475 1476 procedure Process (Src_Node : Node_Access) is 1477 E : Element_Type renames Src_Node.Element.all; 1478 B : Buckets_Type renames Tgt_HT.Buckets.all; 1479 J : constant Hash_Type := Hash (E) mod B'Length; 1480 N : Count_Type renames Tgt_HT.Length; 1481 1482 begin 1483 if B (J) = null then 1484 declare 1485 X : Element_Access := new Element_Type'(E); 1486 begin 1487 B (J) := new Node_Type'(X, null); 1488 exception 1489 when others => 1490 Free_Element (X); 1491 raise; 1492 end; 1493 1494 N := N + 1; 1495 1496 elsif Equivalent_Elements (E, B (J).Element.all) then 1497 declare 1498 X : Node_Access := B (J); 1499 begin 1500 B (J) := B (J).Next; 1501 N := N - 1; 1502 Free (X); 1503 end; 1504 1505 else 1506 declare 1507 Prev : Node_Access := B (J); 1508 Curr : Node_Access := Prev.Next; 1509 1510 begin 1511 while Curr /= null loop 1512 if Equivalent_Elements (E, Curr.Element.all) then 1513 Prev.Next := Curr.Next; 1514 N := N - 1; 1515 Free (Curr); 1516 return; 1517 end if; 1518 1519 Prev := Curr; 1520 Curr := Prev.Next; 1521 end loop; 1522 1523 declare 1524 X : Element_Access := new Element_Type'(E); 1525 begin 1526 B (J) := new Node_Type'(X, B (J)); 1527 exception 1528 when others => 1529 Free_Element (X); 1530 raise; 1531 end; 1532 1533 N := N + 1; 1534 end; 1535 end if; 1536 end Process; 1537 1538 -- Per AI05-0022, the container implementation is required to 1539 -- detect element tampering by a generic actual subprogram. 1540 1541 Lock_Tgt : With_Lock (Tgt_HT.TC'Unrestricted_Access); 1542 Lock_Src : With_Lock (Src_HT.TC'Unrestricted_Access); 1543 1544 -- Start of processing for Iterate_Source 1545 1546 begin 1547 Iterate (Src_HT); 1548 end Iterate_Source; 1549 end if; 1550 end Symmetric_Difference; 1551 1552 function Symmetric_Difference (Left, Right : Set) return Set is 1553 Left_HT : Hash_Table_Type renames Left'Unrestricted_Access.HT; 1554 Right_HT : Hash_Table_Type renames Right'Unrestricted_Access.HT; 1555 Buckets : HT_Types.Buckets_Access; 1556 Length : Count_Type; 1557 1558 begin 1559 if Left'Address = Right'Address then 1560 return Empty_Set; 1561 end if; 1562 1563 if Right.Length = 0 then 1564 return Left; 1565 end if; 1566 1567 if Left.Length = 0 then 1568 return Right; 1569 end if; 1570 1571 declare 1572 Size : constant Hash_Type := 1573 Prime_Numbers.To_Prime (Left.Length + Right.Length); 1574 begin 1575 Buckets := HT_Ops.New_Buckets (Length => Size); 1576 end; 1577 1578 Length := 0; 1579 1580 Iterate_Left : declare 1581 procedure Process (L_Node : Node_Access); 1582 1583 procedure Iterate is 1584 new HT_Ops.Generic_Iteration (Process); 1585 1586 ------------- 1587 -- Process -- 1588 ------------- 1589 1590 procedure Process (L_Node : Node_Access) is 1591 begin 1592 if not Is_In (Right_HT, L_Node) then 1593 declare 1594 E : Element_Type renames L_Node.Element.all; 1595 1596 -- Per AI05-0022, the container implementation is required 1597 -- to detect element tampering by a generic actual 1598 -- subprogram, hence the use of Checked_Index instead of a 1599 -- simple invocation of generic formal Hash. 1600 1601 J : constant Hash_Type := 1602 HT_Ops.Checked_Index (Left_HT, Buckets.all, L_Node); 1603 1604 begin 1605 declare 1606 X : Element_Access := new Element_Type'(E); 1607 begin 1608 Buckets (J) := new Node_Type'(X, Buckets (J)); 1609 exception 1610 when others => 1611 Free_Element (X); 1612 raise; 1613 end; 1614 1615 Length := Length + 1; 1616 end; 1617 end if; 1618 end Process; 1619 1620 -- Start of processing for Iterate_Left 1621 1622 begin 1623 Iterate (Left_HT); 1624 exception 1625 when others => 1626 HT_Ops.Free_Hash_Table (Buckets); 1627 raise; 1628 end Iterate_Left; 1629 1630 Iterate_Right : declare 1631 procedure Process (R_Node : Node_Access); 1632 1633 procedure Iterate is 1634 new HT_Ops.Generic_Iteration (Process); 1635 1636 ------------- 1637 -- Process -- 1638 ------------- 1639 1640 procedure Process (R_Node : Node_Access) is 1641 begin 1642 if not Is_In (Left_HT, R_Node) then 1643 declare 1644 E : Element_Type renames R_Node.Element.all; 1645 1646 -- Per AI05-0022, the container implementation is required 1647 -- to detect element tampering by a generic actual 1648 -- subprogram, hence the use of Checked_Index instead of a 1649 -- simple invocation of generic formal Hash. 1650 1651 J : constant Hash_Type := 1652 HT_Ops.Checked_Index (Right_HT, Buckets.all, R_Node); 1653 1654 begin 1655 declare 1656 X : Element_Access := new Element_Type'(E); 1657 begin 1658 Buckets (J) := new Node_Type'(X, Buckets (J)); 1659 exception 1660 when others => 1661 Free_Element (X); 1662 raise; 1663 end; 1664 1665 Length := Length + 1; 1666 end; 1667 end if; 1668 end Process; 1669 1670 -- Start of processing for Iterate_Right 1671 1672 begin 1673 Iterate (Right_HT); 1674 1675 exception 1676 when others => 1677 HT_Ops.Free_Hash_Table (Buckets); 1678 raise; 1679 end Iterate_Right; 1680 1681 return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); 1682 end Symmetric_Difference; 1683 1684 ------------ 1685 -- To_Set -- 1686 ------------ 1687 1688 function To_Set (New_Item : Element_Type) return Set is 1689 HT : Hash_Table_Type; 1690 Node : Node_Access; 1691 Inserted : Boolean; 1692 pragma Unreferenced (Node, Inserted); 1693 begin 1694 Insert (HT, New_Item, Node, Inserted); 1695 return Set'(Controlled with HT); 1696 end To_Set; 1697 1698 ----------- 1699 -- Union -- 1700 ----------- 1701 1702 procedure Union 1703 (Target : in out Set; 1704 Source : Set) 1705 is 1706 procedure Process (Src_Node : Node_Access); 1707 1708 procedure Iterate is 1709 new HT_Ops.Generic_Iteration (Process); 1710 1711 ------------- 1712 -- Process -- 1713 ------------- 1714 1715 procedure Process (Src_Node : Node_Access) is 1716 Src : Element_Type renames Src_Node.Element.all; 1717 1718 function New_Node (Next : Node_Access) return Node_Access; 1719 pragma Inline (New_Node); 1720 1721 procedure Insert is 1722 new Element_Keys.Generic_Conditional_Insert (New_Node); 1723 1724 -------------- 1725 -- New_Node -- 1726 -------------- 1727 1728 function New_Node (Next : Node_Access) return Node_Access is 1729 Tgt : Element_Access := new Element_Type'(Src); 1730 begin 1731 return new Node_Type'(Tgt, Next); 1732 exception 1733 when others => 1734 Free_Element (Tgt); 1735 raise; 1736 end New_Node; 1737 1738 Tgt_Node : Node_Access; 1739 Success : Boolean; 1740 pragma Unreferenced (Tgt_Node, Success); 1741 1742 -- Start of processing for Process 1743 1744 begin 1745 Insert (Target.HT, Src, Tgt_Node, Success); 1746 end Process; 1747 1748 -- Start of processing for Union 1749 1750 begin 1751 if Target'Address = Source'Address then 1752 return; 1753 end if; 1754 1755 TC_Check (Target.HT.TC); 1756 1757 declare 1758 N : constant Count_Type := Target.Length + Source.Length; 1759 begin 1760 if N > HT_Ops.Capacity (Target.HT) then 1761 HT_Ops.Reserve_Capacity (Target.HT, N); 1762 end if; 1763 end; 1764 1765 Iterate (Source.HT); 1766 end Union; 1767 1768 function Union (Left, Right : Set) return Set is 1769 Left_HT : Hash_Table_Type renames Left.HT'Unrestricted_Access.all; 1770 Right_HT : Hash_Table_Type renames Right.HT'Unrestricted_Access.all; 1771 Buckets : HT_Types.Buckets_Access; 1772 Length : Count_Type; 1773 1774 begin 1775 if Left'Address = Right'Address then 1776 return Left; 1777 end if; 1778 1779 if Right.Length = 0 then 1780 return Left; 1781 end if; 1782 1783 if Left.Length = 0 then 1784 return Right; 1785 end if; 1786 1787 declare 1788 Size : constant Hash_Type := 1789 Prime_Numbers.To_Prime (Left.Length + Right.Length); 1790 begin 1791 Buckets := HT_Ops.New_Buckets (Length => Size); 1792 end; 1793 1794 Iterate_Left : declare 1795 procedure Process (L_Node : Node_Access); 1796 1797 procedure Iterate is 1798 new HT_Ops.Generic_Iteration (Process); 1799 1800 ------------- 1801 -- Process -- 1802 ------------- 1803 1804 procedure Process (L_Node : Node_Access) is 1805 Src : Element_Type renames L_Node.Element.all; 1806 J : constant Hash_Type := Hash (Src) mod Buckets'Length; 1807 Bucket : Node_Access renames Buckets (J); 1808 Tgt : Element_Access := new Element_Type'(Src); 1809 begin 1810 Bucket := new Node_Type'(Tgt, Bucket); 1811 exception 1812 when others => 1813 Free_Element (Tgt); 1814 raise; 1815 end Process; 1816 1817 -- Per AI05-0022, the container implementation is required to detect 1818 -- element tampering by a generic actual subprogram, hence the use of 1819 -- Checked_Index instead of a simple invocation of generic formal 1820 -- Hash. 1821 1822 Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access); 1823 1824 -- Start of processing for Iterate_Left 1825 1826 begin 1827 Iterate (Left_HT); 1828 exception 1829 when others => 1830 HT_Ops.Free_Hash_Table (Buckets); 1831 raise; 1832 end Iterate_Left; 1833 1834 Length := Left.Length; 1835 1836 Iterate_Right : declare 1837 procedure Process (Src_Node : Node_Access); 1838 1839 procedure Iterate is 1840 new HT_Ops.Generic_Iteration (Process); 1841 1842 ------------- 1843 -- Process -- 1844 ------------- 1845 1846 procedure Process (Src_Node : Node_Access) is 1847 Src : Element_Type renames Src_Node.Element.all; 1848 Idx : constant Hash_Type := Hash (Src) mod Buckets'Length; 1849 1850 Tgt_Node : Node_Access := Buckets (Idx); 1851 1852 begin 1853 while Tgt_Node /= null loop 1854 if Equivalent_Elements (Src, Tgt_Node.Element.all) then 1855 return; 1856 end if; 1857 Tgt_Node := Next (Tgt_Node); 1858 end loop; 1859 1860 declare 1861 Tgt : Element_Access := new Element_Type'(Src); 1862 begin 1863 Buckets (Idx) := new Node_Type'(Tgt, Buckets (Idx)); 1864 exception 1865 when others => 1866 Free_Element (Tgt); 1867 raise; 1868 end; 1869 1870 Length := Length + 1; 1871 end Process; 1872 1873 -- Per AI05-0022, the container implementation is required to detect 1874 -- element tampering by a generic actual subprogram, hence the use of 1875 -- Checked_Index instead of a simple invocation of generic formal 1876 -- Hash. 1877 1878 Lock_Left : With_Lock (Left_HT.TC'Unrestricted_Access); 1879 Lock_Right : With_Lock (Right_HT.TC'Unrestricted_Access); 1880 1881 -- Start of processing for Iterate_Right 1882 1883 begin 1884 Iterate (Right.HT); 1885 exception 1886 when others => 1887 HT_Ops.Free_Hash_Table (Buckets); 1888 raise; 1889 end Iterate_Right; 1890 1891 return (Controlled with HT => (Buckets, Length, (Busy => 0, Lock => 0))); 1892 end Union; 1893 1894 --------- 1895 -- Vet -- 1896 --------- 1897 1898 function Vet (Position : Cursor) return Boolean is 1899 begin 1900 if Position.Node = null then 1901 return Position.Container = null; 1902 end if; 1903 1904 if Position.Container = null then 1905 return False; 1906 end if; 1907 1908 if Position.Node.Next = Position.Node then 1909 return False; 1910 end if; 1911 1912 if Position.Node.Element = null then 1913 return False; 1914 end if; 1915 1916 declare 1917 HT : Hash_Table_Type renames Position.Container.HT; 1918 X : Node_Access; 1919 1920 begin 1921 if HT.Length = 0 then 1922 return False; 1923 end if; 1924 1925 if HT.Buckets = null 1926 or else HT.Buckets'Length = 0 1927 then 1928 return False; 1929 end if; 1930 1931 X := HT.Buckets (Element_Keys.Checked_Index 1932 (HT, 1933 Position.Node.Element.all)); 1934 1935 for J in 1 .. HT.Length loop 1936 if X = Position.Node then 1937 return True; 1938 end if; 1939 1940 if X = null then 1941 return False; 1942 end if; 1943 1944 if X = X.Next then -- to prevent unnecessary looping 1945 return False; 1946 end if; 1947 1948 X := X.Next; 1949 end loop; 1950 1951 return False; 1952 end; 1953 end Vet; 1954 1955 ----------- 1956 -- Write -- 1957 ----------- 1958 1959 procedure Write 1960 (Stream : not null access Root_Stream_Type'Class; 1961 Container : Set) 1962 is 1963 begin 1964 Write_Nodes (Stream, Container.HT); 1965 end Write; 1966 1967 procedure Write 1968 (Stream : not null access Root_Stream_Type'Class; 1969 Item : Cursor) 1970 is 1971 begin 1972 raise Program_Error with "attempt to stream set cursor"; 1973 end Write; 1974 1975 procedure Write 1976 (Stream : not null access Root_Stream_Type'Class; 1977 Item : Constant_Reference_Type) 1978 is 1979 begin 1980 raise Program_Error with "attempt to stream reference"; 1981 end Write; 1982 1983 ---------------- 1984 -- Write_Node -- 1985 ---------------- 1986 1987 procedure Write_Node 1988 (Stream : not null access Root_Stream_Type'Class; 1989 Node : Node_Access) 1990 is 1991 begin 1992 Element_Type'Output (Stream, Node.Element.all); 1993 end Write_Node; 1994 1995 package body Generic_Keys is 1996 1997 ----------------------- 1998 -- Local Subprograms -- 1999 ----------------------- 2000 2001 function Equivalent_Key_Node 2002 (Key : Key_Type; 2003 Node : Node_Access) return Boolean; 2004 pragma Inline (Equivalent_Key_Node); 2005 2006 -------------------------- 2007 -- Local Instantiations -- 2008 -------------------------- 2009 2010 package Key_Keys is 2011 new Hash_Tables.Generic_Keys 2012 (HT_Types => HT_Types, 2013 Next => Next, 2014 Set_Next => Set_Next, 2015 Key_Type => Key_Type, 2016 Hash => Hash, 2017 Equivalent_Keys => Equivalent_Key_Node); 2018 2019 ------------------------ 2020 -- Constant_Reference -- 2021 ------------------------ 2022 2023 function Constant_Reference 2024 (Container : aliased Set; 2025 Key : Key_Type) return Constant_Reference_Type 2026 is 2027 HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; 2028 Node : constant Node_Access := Key_Keys.Find (HT, Key); 2029 2030 begin 2031 if Checks and then Node = null then 2032 raise Constraint_Error with "Key not in set"; 2033 end if; 2034 2035 if Checks and then Node.Element = null then 2036 raise Program_Error with "Node has no element"; 2037 end if; 2038 2039 declare 2040 TC : constant Tamper_Counts_Access := 2041 HT.TC'Unrestricted_Access; 2042 begin 2043 return R : constant Constant_Reference_Type := 2044 (Element => Node.Element.all'Access, 2045 Control => (Controlled with TC)) 2046 do 2047 Lock (TC.all); 2048 end return; 2049 end; 2050 end Constant_Reference; 2051 2052 -------------- 2053 -- Contains -- 2054 -------------- 2055 2056 function Contains 2057 (Container : Set; 2058 Key : Key_Type) return Boolean 2059 is 2060 begin 2061 return Find (Container, Key) /= No_Element; 2062 end Contains; 2063 2064 ------------ 2065 -- Delete -- 2066 ------------ 2067 2068 procedure Delete 2069 (Container : in out Set; 2070 Key : Key_Type) 2071 is 2072 X : Node_Access; 2073 2074 begin 2075 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); 2076 2077 if Checks and then X = null then 2078 raise Constraint_Error with "key not in set"; 2079 end if; 2080 2081 Free (X); 2082 end Delete; 2083 2084 ------------- 2085 -- Element -- 2086 ------------- 2087 2088 function Element 2089 (Container : Set; 2090 Key : Key_Type) return Element_Type 2091 is 2092 HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; 2093 Node : constant Node_Access := Key_Keys.Find (HT, Key); 2094 2095 begin 2096 if Checks and then Node = null then 2097 raise Constraint_Error with "key not in set"; 2098 end if; 2099 2100 return Node.Element.all; 2101 end Element; 2102 2103 ------------------------- 2104 -- Equivalent_Key_Node -- 2105 ------------------------- 2106 2107 function Equivalent_Key_Node 2108 (Key : Key_Type; 2109 Node : Node_Access) return Boolean is 2110 begin 2111 return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element.all)); 2112 end Equivalent_Key_Node; 2113 2114 ------------- 2115 -- Exclude -- 2116 ------------- 2117 2118 procedure Exclude 2119 (Container : in out Set; 2120 Key : Key_Type) 2121 is 2122 X : Node_Access; 2123 begin 2124 Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X); 2125 Free (X); 2126 end Exclude; 2127 2128 -------------- 2129 -- Finalize -- 2130 -------------- 2131 2132 procedure Finalize (Control : in out Reference_Control_Type) is 2133 begin 2134 if Control.Container /= null then 2135 Impl.Reference_Control_Type (Control).Finalize; 2136 2137 if Checks and then Hash (Key (Control.Old_Pos)) /= Control.Old_Hash 2138 then 2139 HT_Ops.Delete_Node_At_Index 2140 (Control.Container.HT, Control.Index, Control.Old_Pos.Node); 2141 raise Program_Error; 2142 end if; 2143 2144 Control.Container := null; 2145 end if; 2146 end Finalize; 2147 2148 ---------- 2149 -- Find -- 2150 ---------- 2151 2152 function Find 2153 (Container : Set; 2154 Key : Key_Type) return Cursor 2155 is 2156 HT : Hash_Table_Type renames Container'Unrestricted_Access.HT; 2157 Node : constant Node_Access := Key_Keys.Find (HT, Key); 2158 begin 2159 return (if Node = null then No_Element 2160 else Cursor'(Container'Unrestricted_Access, Node)); 2161 end Find; 2162 2163 --------- 2164 -- Key -- 2165 --------- 2166 2167 function Key (Position : Cursor) return Key_Type is 2168 begin 2169 if Checks and then Position.Node = null then 2170 raise Constraint_Error with 2171 "Position cursor equals No_Element"; 2172 end if; 2173 2174 if Checks and then Position.Node.Element = null then 2175 raise Program_Error with "Position cursor is bad"; 2176 end if; 2177 2178 pragma Assert (Vet (Position), "bad cursor in function Key"); 2179 2180 return Key (Position.Node.Element.all); 2181 end Key; 2182 2183 ---------- 2184 -- Read -- 2185 ---------- 2186 2187 procedure Read 2188 (Stream : not null access Root_Stream_Type'Class; 2189 Item : out Reference_Type) 2190 is 2191 begin 2192 raise Program_Error with "attempt to stream reference"; 2193 end Read; 2194 2195 ------------------------------ 2196 -- Reference_Preserving_Key -- 2197 ------------------------------ 2198 2199 function Reference_Preserving_Key 2200 (Container : aliased in out Set; 2201 Position : Cursor) return Reference_Type 2202 is 2203 begin 2204 if Checks and then Position.Container = null then 2205 raise Constraint_Error with "Position cursor has no element"; 2206 end if; 2207 2208 if Checks and then Position.Container /= Container'Unrestricted_Access 2209 then 2210 raise Program_Error with 2211 "Position cursor designates wrong container"; 2212 end if; 2213 2214 if Checks and then Position.Node.Element = null then 2215 raise Program_Error with "Node has no element"; 2216 end if; 2217 2218 pragma Assert 2219 (Vet (Position), 2220 "bad cursor in function Reference_Preserving_Key"); 2221 2222 declare 2223 HT : Hash_Table_Type renames Container.HT; 2224 begin 2225 return R : constant Reference_Type := 2226 (Element => Position.Node.Element.all'Access, 2227 Control => 2228 (Controlled with 2229 HT.TC'Unrestricted_Access, 2230 Container => Container'Access, 2231 Index => HT_Ops.Index (HT, Position.Node), 2232 Old_Pos => Position, 2233 Old_Hash => Hash (Key (Position)))) 2234 do 2235 Lock (HT.TC); 2236 end return; 2237 end; 2238 end Reference_Preserving_Key; 2239 2240 function Reference_Preserving_Key 2241 (Container : aliased in out Set; 2242 Key : Key_Type) return Reference_Type 2243 is 2244 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); 2245 2246 begin 2247 if Checks and then Node = null then 2248 raise Constraint_Error with "Key not in set"; 2249 end if; 2250 2251 if Checks and then Node.Element = null then 2252 raise Program_Error with "Node has no element"; 2253 end if; 2254 2255 declare 2256 HT : Hash_Table_Type renames Container.HT; 2257 P : constant Cursor := Find (Container, Key); 2258 begin 2259 return R : constant Reference_Type := 2260 (Element => Node.Element.all'Access, 2261 Control => 2262 (Controlled with 2263 HT.TC'Unrestricted_Access, 2264 Container => Container'Access, 2265 Index => HT_Ops.Index (HT, P.Node), 2266 Old_Pos => P, 2267 Old_Hash => Hash (Key))) 2268 do 2269 Lock (HT.TC); 2270 end return; 2271 end; 2272 end Reference_Preserving_Key; 2273 2274 ------------- 2275 -- Replace -- 2276 ------------- 2277 2278 procedure Replace 2279 (Container : in out Set; 2280 Key : Key_Type; 2281 New_Item : Element_Type) 2282 is 2283 Node : constant Node_Access := Key_Keys.Find (Container.HT, Key); 2284 2285 begin 2286 if Checks and then Node = null then 2287 raise Constraint_Error with 2288 "attempt to replace key not in set"; 2289 end if; 2290 2291 Replace_Element (Container.HT, Node, New_Item); 2292 end Replace; 2293 2294 ----------------------------------- 2295 -- Update_Element_Preserving_Key -- 2296 ----------------------------------- 2297 2298 procedure Update_Element_Preserving_Key 2299 (Container : in out Set; 2300 Position : Cursor; 2301 Process : not null access 2302 procedure (Element : in out Element_Type)) 2303 is 2304 HT : Hash_Table_Type renames Container.HT; 2305 Indx : Hash_Type; 2306 2307 begin 2308 if Checks and then Position.Node = null then 2309 raise Constraint_Error with 2310 "Position cursor equals No_Element"; 2311 end if; 2312 2313 if Checks and then 2314 (Position.Node.Element = null 2315 or else Position.Node.Next = Position.Node) 2316 then 2317 raise Program_Error with "Position cursor is bad"; 2318 end if; 2319 2320 if Checks and then Position.Container /= Container'Unrestricted_Access 2321 then 2322 raise Program_Error with 2323 "Position cursor designates wrong set"; 2324 end if; 2325 2326 if Checks and then 2327 (HT.Buckets = null 2328 or else HT.Buckets'Length = 0 2329 or else HT.Length = 0) 2330 then 2331 raise Program_Error with "Position cursor is bad (set is empty)"; 2332 end if; 2333 2334 pragma Assert 2335 (Vet (Position), 2336 "bad cursor in Update_Element_Preserving_Key"); 2337 2338 -- Per AI05-0022, the container implementation is required to detect 2339 -- element tampering by a generic actual subprogram. 2340 2341 declare 2342 E : Element_Type renames Position.Node.Element.all; 2343 K : constant Key_Type := Key (E); 2344 Lock : With_Lock (HT.TC'Unrestricted_Access); 2345 begin 2346 Indx := HT_Ops.Index (HT, Position.Node); 2347 Process (E); 2348 2349 if Equivalent_Keys (K, Key (E)) then 2350 return; 2351 end if; 2352 end; 2353 2354 if HT.Buckets (Indx) = Position.Node then 2355 HT.Buckets (Indx) := Position.Node.Next; 2356 2357 else 2358 declare 2359 Prev : Node_Access := HT.Buckets (Indx); 2360 2361 begin 2362 while Prev.Next /= Position.Node loop 2363 Prev := Prev.Next; 2364 2365 if Checks and then Prev = null then 2366 raise Program_Error with 2367 "Position cursor is bad (node not found)"; 2368 end if; 2369 end loop; 2370 2371 Prev.Next := Position.Node.Next; 2372 end; 2373 end if; 2374 2375 HT.Length := HT.Length - 1; 2376 2377 declare 2378 X : Node_Access := Position.Node; 2379 2380 begin 2381 Free (X); 2382 end; 2383 2384 raise Program_Error with "key was modified"; 2385 end Update_Element_Preserving_Key; 2386 2387 ----------- 2388 -- Write -- 2389 ----------- 2390 2391 procedure Write 2392 (Stream : not null access Root_Stream_Type'Class; 2393 Item : Reference_Type) 2394 is 2395 begin 2396 raise Program_Error with "attempt to stream reference"; 2397 end Write; 2398 2399 end Generic_Keys; 2400 2401end Ada.Containers.Indefinite_Hashed_Sets; 2402