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