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