gcc/ada/libgnat/a-cihase.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                  ADA.CONTAINERS.INDEFINITE_HASHED_SETS                   --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2004-2017, 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
  30 with Ada.Unchecked_Deallocation;
  31
  32 with Ada.Containers.Hash_Tables.Generic_Operations;
  33 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
  34
  35 with Ada.Containers.Hash_Tables.Generic_Keys;
  36 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
  37
  38 with Ada.Containers.Helpers; use Ada.Containers.Helpers;
  39
  40 with Ada.Containers.Prime_Numbers;
  41
  42 with System; use type System.Address;
  43
  44 package 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 < Source.Length then
 268          if Checks and then Capacity /= 0 then
 269             raise Capacity_Error
 270               with "Requested capacity is less than Source length";
 271          end if;
 272
 273          C := Source.Length;
 274       else
 275          C := Capacity;
 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
2401 end Ada.Containers.Indefinite_Hashed_Sets;