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