gcc/ada/a-cfhase.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --    A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ S E T S     --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2010-2013, 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
  28 with Ada.Containers.Hash_Tables.Generic_Bounded_Operations;
  29 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations);
  30
  31 with Ada.Containers.Hash_Tables.Generic_Bounded_Keys;
  32 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys);
  33
  34 with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
  35
  36 with System; use type System.Address;
  37
  38 package body Ada.Containers.Formal_Hashed_Sets is
  39
  40    -----------------------
  41    -- Local Subprograms --
  42    -----------------------
  43
  44    --  All need comments ???
  45
  46    procedure Difference
  47      (Left, Right : Set;
  48       Target      : in out Set);
  49
  50    function Equivalent_Keys
  51      (Key  : Element_Type;
  52       Node : Node_Type) return Boolean;
  53    pragma Inline (Equivalent_Keys);
  54
  55    procedure Free
  56      (HT : in out Set;
  57       X  : Count_Type);
  58
  59    generic
  60       with procedure Set_Element (Node : in out Node_Type);
  61    procedure Generic_Allocate
  62      (HT   : in out Set;
  63       Node : out Count_Type);
  64
  65    function Hash_Node (Node : Node_Type) return Hash_Type;
  66    pragma Inline (Hash_Node);
  67
  68    procedure Insert
  69      (Container       : in out Set;
  70       New_Item : Element_Type;
  71       Node     : out Count_Type;
  72       Inserted : out Boolean);
  73
  74    procedure Intersection
  75      (Left   : Set;
  76       Right  : Set;
  77       Target : in out Set);
  78
  79    function Is_In
  80      (HT  : Set;
  81       Key : Node_Type) return Boolean;
  82    pragma Inline (Is_In);
  83
  84    procedure Set_Element (Node : in out Node_Type; Item : Element_Type);
  85    pragma Inline (Set_Element);
  86
  87    function Next (Node : Node_Type) return Count_Type;
  88    pragma Inline (Next);
  89
  90    procedure Set_Next (Node : in out Node_Type; Next : Count_Type);
  91    pragma Inline (Set_Next);
  92
  93    function Vet (Container : Set; Position : Cursor) return Boolean;
  94
  95    --------------------------
  96    -- Local Instantiations --
  97    --------------------------
  98
  99    package HT_Ops is new Hash_Tables.Generic_Bounded_Operations
 100      (HT_Types  => HT_Types,
 101       Hash_Node => Hash_Node,
 102       Next      => Next,
 103       Set_Next  => Set_Next);
 104
 105    package Element_Keys is new Hash_Tables.Generic_Bounded_Keys
 106      (HT_Types        => HT_Types,
 107       Next            => Next,
 108       Set_Next        => Set_Next,
 109       Key_Type        => Element_Type,
 110       Hash            => Hash,
 111       Equivalent_Keys => Equivalent_Keys);
 112
 113    procedure Replace_Element is
 114      new Element_Keys.Generic_Replace_Element (Hash_Node, Set_Element);
 115
 116    ---------
 117    -- "=" --
 118    ---------
 119
 120    function "=" (Left, Right : Set) return Boolean is
 121    begin
 122       if Length (Left) /= Length (Right) then
 123          return False;
 124       end if;
 125
 126       if Length (Left) = 0 then
 127          return True;
 128       end if;
 129
 130       declare
 131          Node  : Count_Type;
 132          ENode : Count_Type;
 133
 134       begin
 135          Node  := First (Left).Node;
 136          while Node /= 0 loop
 137             ENode := Find (Container => Right,
 138                            Item      => Left.Nodes (Node).Element).Node;
 139             if ENode = 0 or else
 140               Right.Nodes (ENode).Element /= Left.Nodes (Node).Element
 141             then
 142                return False;
 143             end if;
 144
 145             Node := HT_Ops.Next (Left, Node);
 146          end loop;
 147
 148          return True;
 149
 150       end;
 151
 152    end "=";
 153
 154    ------------
 155    -- Assign --
 156    ------------
 157
 158    procedure Assign (Target : in out Set; Source : Set) is
 159       procedure Insert_Element (Source_Node : Count_Type);
 160
 161       procedure Insert_Elements is
 162         new HT_Ops.Generic_Iteration (Insert_Element);
 163
 164       --------------------
 165       -- Insert_Element --
 166       --------------------
 167
 168       procedure Insert_Element (Source_Node : Count_Type) is
 169          N : Node_Type renames Source.Nodes (Source_Node);
 170          X : Count_Type;
 171          B : Boolean;
 172
 173       begin
 174          Insert (Target, N.Element, X, B);
 175          pragma Assert (B);
 176       end Insert_Element;
 177
 178    --  Start of processing for Assign
 179
 180    begin
 181       if Target'Address = Source'Address then
 182          return;
 183       end if;
 184
 185       if Target.Capacity < Length (Source) then
 186          raise Storage_Error with "not enough capacity";  -- SE or CE? ???
 187       end if;
 188
 189       HT_Ops.Clear (Target);
 190       Insert_Elements (Source);
 191    end Assign;
 192
 193    --------------
 194    -- Capacity --
 195    --------------
 196
 197    function Capacity (Container : Set) return Count_Type is
 198    begin
 199       return Container.Nodes'Length;
 200    end Capacity;
 201
 202    -----------
 203    -- Clear --
 204    -----------
 205
 206    procedure Clear (Container : in out Set) is
 207    begin
 208       HT_Ops.Clear (Container);
 209    end Clear;
 210
 211    --------------
 212    -- Contains --
 213    --------------
 214
 215    function Contains (Container : Set; Item : Element_Type) return Boolean is
 216    begin
 217       return Find (Container, Item) /= No_Element;
 218    end Contains;
 219
 220    ----------
 221    -- Copy --
 222    ----------
 223
 224    function Copy
 225      (Source   : Set;
 226       Capacity : Count_Type := 0) return Set
 227    is
 228       C      : constant Count_Type :=
 229         Count_Type'Max (Capacity, Source.Capacity);
 230       H      : Hash_Type;
 231       N      : Count_Type;
 232       Target : Set (C, Source.Modulus);
 233       Cu     : Cursor;
 234
 235    begin
 236       if 0 < Capacity and then Capacity < Source.Capacity then
 237          raise Capacity_Error;
 238       end if;
 239
 240       Target.Length := Source.Length;
 241       Target.Free := Source.Free;
 242
 243       H := 1;
 244       while H <= Source.Modulus loop
 245          Target.Buckets (H) := Source.Buckets (H);
 246          H := H + 1;
 247       end loop;
 248
 249       N := 1;
 250       while N <= Source.Capacity loop
 251          Target.Nodes (N) := Source.Nodes (N);
 252          N := N + 1;
 253       end loop;
 254
 255       while N <= C loop
 256          Cu := (Node => N);
 257          Free (Target, Cu.Node);
 258          N := N + 1;
 259       end loop;
 260
 261       return Target;
 262    end Copy;
 263
 264    ---------------------
 265    -- Default_Modulus --
 266    ---------------------
 267
 268    function Default_Modulus (Capacity : Count_Type) return Hash_Type is
 269    begin
 270       return To_Prime (Capacity);
 271    end Default_Modulus;
 272
 273    ------------
 274    -- Delete --
 275    ------------
 276
 277    procedure Delete
 278      (Container : in out Set;
 279       Item      : Element_Type)
 280    is
 281       X : Count_Type;
 282
 283    begin
 284       Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
 285
 286       if X = 0 then
 287          raise Constraint_Error with "attempt to delete element not in set";
 288       end if;
 289
 290       Free (Container, X);
 291    end Delete;
 292
 293    procedure Delete
 294      (Container : in out Set;
 295       Position  : in out Cursor)
 296    is
 297    begin
 298       if not Has_Element (Container, Position) then
 299          raise Constraint_Error with "Position cursor has no element";
 300       end if;
 301
 302       pragma Assert (Vet (Container, Position), "bad cursor in Delete");
 303
 304       HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
 305       Free (Container, Position.Node);
 306
 307       Position := No_Element;
 308    end Delete;
 309
 310    ----------------
 311    -- Difference --
 312    ----------------
 313
 314    procedure Difference
 315      (Target : in out Set;
 316       Source : Set)
 317    is
 318       Tgt_Node, Src_Node, Src_Last, Src_Length : Count_Type;
 319
 320       TN : Nodes_Type renames Target.Nodes;
 321       SN : Nodes_Type renames Source.Nodes;
 322
 323    begin
 324       if Target'Address = Source'Address then
 325          Clear (Target);
 326          return;
 327       end if;
 328
 329       Src_Length := Source.Length;
 330
 331       if Src_Length = 0 then
 332          return;
 333       end if;
 334
 335       if Src_Length >= Target.Length then
 336          Tgt_Node := HT_Ops.First (Target);
 337          while Tgt_Node /= 0 loop
 338             if Element_Keys.Find (Source, TN (Tgt_Node).Element) /= 0 then
 339                declare
 340                   X : constant Count_Type := Tgt_Node;
 341                begin
 342                   Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
 343                   HT_Ops.Delete_Node_Sans_Free (Target, X);
 344                   Free (Target, X);
 345                end;
 346
 347             else
 348                Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
 349             end if;
 350          end loop;
 351
 352          return;
 353       else
 354          Src_Node := HT_Ops.First (Source);
 355          Src_Last := 0;
 356       end if;
 357
 358       while Src_Node /= Src_Last loop
 359          Tgt_Node := Element_Keys.Find (Target, SN (Src_Node).Element);
 360
 361          if Tgt_Node /= 0 then
 362             HT_Ops.Delete_Node_Sans_Free (Target, Tgt_Node);
 363             Free (Target, Tgt_Node);
 364          end if;
 365
 366          Src_Node := HT_Ops.Next (Source, Src_Node);
 367       end loop;
 368    end Difference;
 369
 370    procedure Difference
 371      (Left, Right : Set;
 372       Target      : in out Set)
 373    is
 374       procedure Process (L_Node : Count_Type);
 375
 376       procedure Iterate is
 377         new HT_Ops.Generic_Iteration (Process);
 378
 379       -------------
 380       -- Process --
 381       -------------
 382
 383       procedure Process (L_Node : Count_Type) is
 384          E : Element_Type renames Left.Nodes (L_Node).Element;
 385          X : Count_Type;
 386          B : Boolean;
 387       begin
 388          if Find (Right, E).Node = 0 then
 389             Insert (Target, E, X, B);
 390             pragma Assert (B);
 391          end if;
 392       end Process;
 393
 394    --  Start of processing for Difference
 395
 396    begin
 397       Iterate (Left);
 398    end Difference;
 399
 400    function Difference (Left, Right : Set) return Set is
 401       C : Count_Type;
 402       H : Hash_Type;
 403
 404    begin
 405       if Left'Address = Right'Address then
 406          return Empty_Set;
 407       end if;
 408
 409       if Length (Left) = 0 then
 410          return Empty_Set;
 411       end if;
 412
 413       if Length (Right) = 0 then
 414          return Left.Copy;
 415       end if;
 416
 417       C := Length (Left);
 418       H := Default_Modulus (C);
 419
 420       return S : Set (C, H) do
 421          Difference (Left, Right, Target => S);
 422       end return;
 423    end Difference;
 424
 425    -------------
 426    -- Element --
 427    -------------
 428
 429    function Element
 430      (Container : Set;
 431       Position  : Cursor) return Element_Type
 432    is
 433    begin
 434       if not Has_Element (Container, Position) then
 435          raise Constraint_Error with "Position cursor equals No_Element";
 436       end if;
 437
 438       pragma Assert (Vet (Container, Position),
 439                      "bad cursor in function Element");
 440
 441       return Container.Nodes (Position.Node).Element;
 442    end Element;
 443
 444    ---------------------
 445    -- Equivalent_Sets --
 446    ---------------------
 447
 448    function Equivalent_Sets (Left, Right : Set) return Boolean is
 449
 450       function Find_Equivalent_Key
 451         (R_HT   : Hash_Table_Type'Class;
 452          L_Node : Node_Type) return Boolean;
 453       pragma Inline (Find_Equivalent_Key);
 454
 455       function Is_Equivalent is
 456         new HT_Ops.Generic_Equal (Find_Equivalent_Key);
 457
 458       -------------------------
 459       -- Find_Equivalent_Key --
 460       -------------------------
 461
 462       function Find_Equivalent_Key
 463         (R_HT   : Hash_Table_Type'Class;
 464          L_Node : Node_Type) return Boolean
 465       is
 466          R_Index : constant Hash_Type :=
 467            Element_Keys.Index (R_HT, L_Node.Element);
 468          R_Node  : Count_Type := R_HT.Buckets (R_Index);
 469          RN      : Nodes_Type renames R_HT.Nodes;
 470
 471       begin
 472          loop
 473             if R_Node = 0 then
 474                return False;
 475             end if;
 476
 477             if Equivalent_Elements
 478                  (L_Node.Element, RN (R_Node).Element)
 479             then
 480                return True;
 481             end if;
 482
 483             R_Node := HT_Ops.Next (R_HT, R_Node);
 484          end loop;
 485       end Find_Equivalent_Key;
 486
 487    --  Start of processing of Equivalent_Sets
 488
 489    begin
 490       return Is_Equivalent (Left, Right);
 491    end Equivalent_Sets;
 492
 493    -------------------------
 494    -- Equivalent_Elements --
 495    -------------------------
 496
 497    function Equivalent_Elements
 498      (Left  : Set;
 499       CLeft : Cursor;
 500       Right  : Set;
 501       CRight : Cursor) return Boolean
 502    is
 503    begin
 504       if not Has_Element (Left, CLeft) then
 505          raise Constraint_Error with
 506            "Left cursor of Equivalent_Elements has no element";
 507       end if;
 508
 509       if not Has_Element (Right, CRight) then
 510          raise Constraint_Error with
 511            "Right cursor of Equivalent_Elements has no element";
 512       end if;
 513
 514       pragma Assert (Vet (Left, CLeft),
 515                      "bad Left cursor in Equivalent_Elements");
 516       pragma Assert (Vet (Right, CRight),
 517                      "bad Right cursor in Equivalent_Elements");
 518
 519       declare
 520          LN : Node_Type renames Left.Nodes (CLeft.Node);
 521          RN : Node_Type renames Right.Nodes (CRight.Node);
 522       begin
 523          return Equivalent_Elements (LN.Element, RN.Element);
 524       end;
 525    end Equivalent_Elements;
 526
 527    function Equivalent_Elements
 528      (Left  : Set;
 529       CLeft : Cursor;
 530       Right : Element_Type) return Boolean
 531    is
 532    begin
 533       if not Has_Element (Left, CLeft) then
 534          raise Constraint_Error with
 535            "Left cursor of Equivalent_Elements has no element";
 536       end if;
 537
 538       pragma Assert (Vet (Left, CLeft),
 539                      "Left cursor in Equivalent_Elements is bad");
 540
 541       declare
 542          LN : Node_Type renames Left.Nodes (CLeft.Node);
 543       begin
 544          return Equivalent_Elements (LN.Element, Right);
 545       end;
 546    end Equivalent_Elements;
 547
 548    function Equivalent_Elements
 549      (Left   : Element_Type;
 550       Right  : Set;
 551       CRight : Cursor) return Boolean
 552    is
 553    begin
 554       if not Has_Element (Right, CRight) then
 555          raise Constraint_Error with
 556            "Right cursor of Equivalent_Elements has no element";
 557       end if;
 558
 559       pragma Assert
 560         (Vet (Right, CRight),
 561          "Right cursor of Equivalent_Elements is bad");
 562
 563       declare
 564          RN : Node_Type renames Right.Nodes (CRight.Node);
 565       begin
 566          return Equivalent_Elements (Left, RN.Element);
 567       end;
 568    end Equivalent_Elements;
 569
 570    ---------------------
 571    -- Equivalent_Keys --
 572    ---------------------
 573
 574    function Equivalent_Keys
 575      (Key  : Element_Type;
 576       Node : Node_Type) return Boolean
 577    is
 578    begin
 579       return Equivalent_Elements (Key, Node.Element);
 580    end Equivalent_Keys;
 581
 582    -------------
 583    -- Exclude --
 584    -------------
 585
 586    procedure Exclude
 587      (Container : in out Set;
 588       Item      : Element_Type)
 589    is
 590       X : Count_Type;
 591    begin
 592       Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
 593       Free (Container, X);
 594    end Exclude;
 595
 596    ----------
 597    -- Find --
 598    ----------
 599
 600    function Find
 601      (Container : Set;
 602       Item      : Element_Type) return Cursor
 603    is
 604       Node : constant Count_Type := Element_Keys.Find (Container, Item);
 605
 606    begin
 607       if Node = 0 then
 608          return No_Element;
 609       end if;
 610
 611       return (Node => Node);
 612    end Find;
 613
 614    -----------
 615    -- First --
 616    -----------
 617
 618    function First (Container : Set) return Cursor is
 619       Node : constant Count_Type := HT_Ops.First (Container);
 620
 621    begin
 622       if Node = 0 then
 623          return No_Element;
 624       end if;
 625
 626       return (Node => Node);
 627    end First;
 628
 629    ----------
 630    -- Free --
 631    ----------
 632
 633    procedure Free
 634      (HT : in out Set;
 635       X  : Count_Type)
 636    is
 637    begin
 638       HT.Nodes (X).Has_Element := False;
 639       HT_Ops.Free (HT, X);
 640    end Free;
 641
 642    ----------------------
 643    -- Generic_Allocate --
 644    ----------------------
 645
 646    procedure Generic_Allocate
 647      (HT   : in out Set;
 648       Node : out Count_Type)
 649    is
 650       procedure Allocate is new HT_Ops.Generic_Allocate (Set_Element);
 651    begin
 652       Allocate (HT, Node);
 653       HT.Nodes (Node).Has_Element := True;
 654    end Generic_Allocate;
 655
 656    -----------------
 657    -- Has_Element --
 658    -----------------
 659
 660    function Has_Element (Container : Set; Position : Cursor) return Boolean is
 661    begin
 662       if Position.Node = 0
 663         or else not Container.Nodes (Position.Node).Has_Element
 664       then
 665          return False;
 666       end if;
 667
 668       return True;
 669    end Has_Element;
 670
 671    ---------------
 672    -- Hash_Node --
 673    ---------------
 674
 675    function Hash_Node (Node : Node_Type) return Hash_Type is
 676    begin
 677       return Hash (Node.Element);
 678    end Hash_Node;
 679
 680    -------------
 681    -- Include --
 682    -------------
 683
 684    procedure Include
 685      (Container : in out Set;
 686       New_Item  : Element_Type)
 687    is
 688       Position : Cursor;
 689       Inserted : Boolean;
 690
 691    begin
 692       Insert (Container, New_Item, Position, Inserted);
 693
 694       if not Inserted then
 695          Container.Nodes (Position.Node).Element := New_Item;
 696       end if;
 697    end Include;
 698
 699    ------------
 700    -- Insert --
 701    ------------
 702
 703    procedure Insert
 704      (Container : in out Set;
 705       New_Item  : Element_Type;
 706       Position  : out Cursor;
 707       Inserted  : out Boolean)
 708    is
 709    begin
 710       Insert (Container, New_Item, Position.Node, Inserted);
 711    end Insert;
 712
 713    procedure Insert
 714      (Container : in out Set;
 715       New_Item  : Element_Type)
 716    is
 717       Position : Cursor;
 718       Inserted : Boolean;
 719
 720    begin
 721       Insert (Container, New_Item, Position, Inserted);
 722
 723       if not Inserted then
 724          raise Constraint_Error with
 725            "attempt to insert element already in set";
 726       end if;
 727    end Insert;
 728
 729    procedure Insert
 730      (Container : in out Set;
 731       New_Item  : Element_Type;
 732       Node      : out Count_Type;
 733       Inserted  : out Boolean)
 734    is
 735       procedure Allocate_Set_Element (Node : in out Node_Type);
 736       pragma Inline (Allocate_Set_Element);
 737
 738       function New_Node return Count_Type;
 739       pragma Inline (New_Node);
 740
 741       procedure Local_Insert is
 742         new Element_Keys.Generic_Conditional_Insert (New_Node);
 743
 744       procedure Allocate is
 745         new Generic_Allocate (Allocate_Set_Element);
 746
 747       ---------------------------
 748       --  Allocate_Set_Element --
 749       ---------------------------
 750
 751       procedure Allocate_Set_Element (Node : in out Node_Type) is
 752       begin
 753          Node.Element := New_Item;
 754       end Allocate_Set_Element;
 755
 756       --------------
 757       -- New_Node --
 758       --------------
 759
 760       function New_Node return Count_Type is
 761          Result : Count_Type;
 762       begin
 763          Allocate (Container, Result);
 764          return Result;
 765       end New_Node;
 766
 767    --  Start of processing for Insert
 768
 769    begin
 770       Local_Insert (Container, New_Item, Node, Inserted);
 771    end Insert;
 772
 773    ------------------
 774    -- Intersection --
 775    ------------------
 776
 777    procedure Intersection
 778      (Target : in out Set;
 779       Source : Set)
 780    is
 781       Tgt_Node : Count_Type;
 782       TN       : Nodes_Type renames Target.Nodes;
 783
 784    begin
 785       if Target'Address = Source'Address then
 786          return;
 787       end if;
 788
 789       if Source.Length = 0 then
 790          Clear (Target);
 791          return;
 792       end if;
 793
 794       Tgt_Node := HT_Ops.First (Target);
 795       while Tgt_Node /= 0 loop
 796          if Find (Source, TN (Tgt_Node).Element).Node /= 0 then
 797             Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
 798
 799          else
 800             declare
 801                X : constant Count_Type := Tgt_Node;
 802             begin
 803                Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
 804                HT_Ops.Delete_Node_Sans_Free (Target, X);
 805                Free (Target, X);
 806             end;
 807          end if;
 808       end loop;
 809    end Intersection;
 810
 811    procedure Intersection
 812      (Left   : Set;
 813       Right  : Set;
 814       Target : in out Set)
 815    is
 816       procedure Process (L_Node : Count_Type);
 817
 818       procedure Iterate is
 819         new HT_Ops.Generic_Iteration (Process);
 820
 821       -------------
 822       -- Process --
 823       -------------
 824
 825       procedure Process (L_Node : Count_Type) is
 826          E : Element_Type renames Left.Nodes (L_Node).Element;
 827          X : Count_Type;
 828          B : Boolean;
 829
 830       begin
 831          if Find (Right, E).Node /= 0 then
 832             Insert (Target, E, X, B);
 833             pragma Assert (B);
 834          end if;
 835       end Process;
 836
 837    --  Start of processing for Intersection
 838
 839    begin
 840       Iterate (Left);
 841    end Intersection;
 842
 843    function Intersection (Left, Right : Set) return Set is
 844       C : Count_Type;
 845       H : Hash_Type;
 846
 847    begin
 848       if Left'Address = Right'Address then
 849          return Left.Copy;
 850       end if;
 851
 852       C := Count_Type'Min (Length (Left), Length (Right));  -- ???
 853       H := Default_Modulus (C);
 854
 855       return S : Set (C, H) do
 856          if Length (Left) /= 0 and Length (Right) /= 0 then
 857                Intersection (Left, Right, Target => S);
 858          end if;
 859       end return;
 860    end Intersection;
 861
 862    --------------
 863    -- Is_Empty --
 864    --------------
 865
 866    function Is_Empty (Container : Set) return Boolean is
 867    begin
 868       return Length (Container) = 0;
 869    end Is_Empty;
 870
 871    -----------
 872    -- Is_In --
 873    -----------
 874
 875    function Is_In (HT : Set; Key : Node_Type) return Boolean is
 876    begin
 877       return Element_Keys.Find (HT, Key.Element) /= 0;
 878    end Is_In;
 879
 880    ---------------
 881    -- Is_Subset --
 882    ---------------
 883
 884    function Is_Subset (Subset : Set; Of_Set : Set) return Boolean is
 885       Subset_Node  : Count_Type;
 886       Subset_Nodes : Nodes_Type renames Subset.Nodes;
 887
 888    begin
 889       if Subset'Address = Of_Set'Address then
 890          return True;
 891       end if;
 892
 893       if Length (Subset) > Length (Of_Set) then
 894          return False;
 895       end if;
 896
 897       Subset_Node := First (Subset).Node;
 898       while Subset_Node /= 0 loop
 899          declare
 900             N : Node_Type renames Subset_Nodes (Subset_Node);
 901             E : Element_Type renames N.Element;
 902
 903          begin
 904             if Find (Of_Set, E).Node = 0 then
 905                return False;
 906             end if;
 907          end;
 908
 909          Subset_Node := HT_Ops.Next (Subset, Subset_Node);
 910       end loop;
 911
 912       return True;
 913    end Is_Subset;
 914
 915    ----------
 916    -- Left --
 917    ----------
 918
 919    function Left (Container : Set; Position : Cursor) return Set is
 920       Curs : Cursor := Position;
 921       C    : Set (Container.Capacity, Container.Modulus) :=
 922         Copy (Container, Container.Capacity);
 923       Node : Count_Type;
 924
 925    begin
 926       if Curs = No_Element then
 927          return C;
 928       end if;
 929
 930       if not Has_Element (Container, Curs) then
 931          raise Constraint_Error;
 932       end if;
 933
 934       while Curs.Node /= 0 loop
 935          Node := Curs.Node;
 936          Delete (C, Curs);
 937          Curs := Next (Container, (Node => Node));
 938       end loop;
 939
 940       return C;
 941    end Left;
 942
 943    ------------
 944    -- Length --
 945    ------------
 946
 947    function Length (Container : Set) return Count_Type is
 948    begin
 949       return Container.Length;
 950    end Length;
 951
 952    ----------
 953    -- Move --
 954    ----------
 955
 956    --  Comments???
 957
 958    procedure Move (Target : in out Set; Source : in out Set) is
 959       NN   : HT_Types.Nodes_Type renames Source.Nodes;
 960       X, Y : Count_Type;
 961
 962    begin
 963       if Target'Address = Source'Address then
 964          return;
 965       end if;
 966
 967       if Target.Capacity < Length (Source) then
 968          raise Constraint_Error with  -- ???
 969            "Source length exceeds Target capacity";
 970       end if;
 971
 972       Clear (Target);
 973
 974       if Source.Length = 0 then
 975          return;
 976       end if;
 977
 978       X := HT_Ops.First (Source);
 979       while X /= 0 loop
 980          Insert (Target, NN (X).Element);  -- optimize???
 981
 982          Y := HT_Ops.Next (Source, X);
 983
 984          HT_Ops.Delete_Node_Sans_Free (Source, X);
 985          Free (Source, X);
 986
 987          X := Y;
 988       end loop;
 989    end Move;
 990
 991    ----------
 992    -- Next --
 993    ----------
 994
 995    function Next (Node : Node_Type) return Count_Type is
 996    begin
 997       return Node.Next;
 998    end Next;
 999
1000    function Next (Container : Set; Position : Cursor) return Cursor is
1001    begin
1002       if Position.Node = 0 then
1003          return No_Element;
1004       end if;
1005
1006       if not Has_Element (Container, Position) then
1007          raise Constraint_Error
1008            with "Position has no element";
1009       end if;
1010
1011       pragma Assert (Vet (Container, Position), "bad cursor in Next");
1012
1013       return (Node => HT_Ops.Next (Container, Position.Node));
1014    end Next;
1015
1016    procedure Next (Container : Set; Position : in out Cursor) is
1017    begin
1018       Position := Next (Container, Position);
1019    end Next;
1020
1021    -------------
1022    -- Overlap --
1023    -------------
1024
1025    function Overlap (Left, Right : Set) return Boolean is
1026       Left_Node  : Count_Type;
1027       Left_Nodes : Nodes_Type renames Left.Nodes;
1028
1029    begin
1030       if Length (Right) = 0 or Length (Left) = 0 then
1031          return False;
1032       end if;
1033
1034       if Left'Address = Right'Address then
1035          return True;
1036       end if;
1037
1038       Left_Node := First (Left).Node;
1039       while Left_Node /= 0 loop
1040          declare
1041             N : Node_Type renames Left_Nodes (Left_Node);
1042             E : Element_Type renames N.Element;
1043          begin
1044             if Find (Right, E).Node /= 0 then
1045                return True;
1046             end if;
1047          end;
1048
1049          Left_Node := HT_Ops.Next (Left, Left_Node);
1050       end loop;
1051
1052       return False;
1053    end Overlap;
1054
1055    -------------
1056    -- Replace --
1057    -------------
1058
1059    procedure Replace
1060      (Container : in out Set;
1061       New_Item  : Element_Type)
1062    is
1063       Node : constant Count_Type := Element_Keys.Find (Container, New_Item);
1064
1065    begin
1066       if Node = 0 then
1067          raise Constraint_Error with
1068            "attempt to replace element not in set";
1069       end if;
1070
1071       Container.Nodes (Node).Element := New_Item;
1072    end Replace;
1073
1074    ---------------------
1075    -- Replace_Element --
1076    ---------------------
1077
1078    procedure Replace_Element
1079      (Container : in out Set;
1080       Position  : Cursor;
1081       New_Item  : Element_Type)
1082    is
1083    begin
1084       if not Has_Element (Container, Position) then
1085          raise Constraint_Error with
1086            "Position cursor equals No_Element";
1087       end if;
1088
1089       pragma Assert (Vet (Container, Position),
1090                      "bad cursor in Replace_Element");
1091
1092       Replace_Element (Container, Position.Node, New_Item);
1093    end Replace_Element;
1094
1095    ----------------------
1096    -- Reserve_Capacity --
1097    ----------------------
1098
1099    procedure Reserve_Capacity
1100      (Container : in out Set;
1101       Capacity  : Count_Type)
1102    is
1103    begin
1104       if Capacity > Container.Capacity then
1105          raise Constraint_Error with "requested capacity is too large";
1106       end if;
1107    end Reserve_Capacity;
1108
1109    -----------
1110    -- Right --
1111    -----------
1112
1113    function Right (Container : Set; Position : Cursor) return Set is
1114       Curs : Cursor := First (Container);
1115       C    : Set (Container.Capacity, Container.Modulus) :=
1116         Copy (Container, Container.Capacity);
1117       Node : Count_Type;
1118
1119    begin
1120       if Curs = No_Element then
1121          Clear (C);
1122          return C;
1123       end if;
1124
1125       if Position /= No_Element and not Has_Element (Container, Position) then
1126          raise Constraint_Error;
1127       end if;
1128
1129       while Curs.Node /= Position.Node loop
1130          Node := Curs.Node;
1131          Delete (C, Curs);
1132          Curs := Next (Container, (Node => Node));
1133       end loop;
1134
1135       return C;
1136    end Right;
1137
1138    ------------------
1139    --  Set_Element --
1140    ------------------
1141
1142    procedure Set_Element (Node : in out Node_Type; Item : Element_Type) is
1143    begin
1144       Node.Element := Item;
1145    end Set_Element;
1146
1147    --------------
1148    -- Set_Next --
1149    --------------
1150
1151    procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is
1152    begin
1153       Node.Next := Next;
1154    end Set_Next;
1155
1156    ------------------
1157    -- Strict_Equal --
1158    ------------------
1159
1160    function Strict_Equal (Left, Right : Set) return Boolean is
1161       CuL : Cursor := First (Left);
1162       CuR : Cursor := First (Right);
1163
1164    begin
1165       if Length (Left) /= Length (Right) then
1166          return False;
1167       end if;
1168
1169       while CuL.Node /= 0 or CuR.Node /= 0 loop
1170          if CuL.Node /= CuR.Node
1171            or else Left.Nodes (CuL.Node).Element /=
1172                    Right.Nodes (CuR.Node).Element
1173          then
1174             return False;
1175          end if;
1176
1177          CuL := Next (Left, CuL);
1178          CuR := Next (Right, CuR);
1179       end loop;
1180
1181       return True;
1182    end Strict_Equal;
1183
1184    --------------------------
1185    -- Symmetric_Difference --
1186    --------------------------
1187
1188    procedure Symmetric_Difference
1189      (Target : in out Set;
1190       Source : Set)
1191    is
1192       procedure Process (Source_Node : Count_Type);
1193       pragma Inline (Process);
1194
1195       procedure Iterate is new HT_Ops.Generic_Iteration (Process);
1196
1197       -------------
1198       -- Process --
1199       -------------
1200
1201       procedure Process (Source_Node : Count_Type) is
1202          N : Node_Type renames Source.Nodes (Source_Node);
1203          X : Count_Type;
1204          B : Boolean;
1205       begin
1206          if Is_In (Target, N) then
1207             Delete (Target, N.Element);
1208          else
1209             Insert (Target, N.Element, X, B);
1210             pragma Assert (B);
1211          end if;
1212       end Process;
1213
1214    --  Start of processing for Symmetric_Difference
1215
1216    begin
1217       if Target'Address = Source'Address then
1218          Clear (Target);
1219          return;
1220       end if;
1221
1222       if Length (Target) = 0 then
1223          Assign (Target, Source);
1224          return;
1225       end if;
1226
1227       Iterate (Source);
1228    end Symmetric_Difference;
1229
1230    function Symmetric_Difference (Left, Right : Set) return Set is
1231       C : Count_Type;
1232       H : Hash_Type;
1233
1234    begin
1235       if Left'Address = Right'Address then
1236          return Empty_Set;
1237       end if;
1238
1239       if Length (Right) = 0 then
1240          return Left.Copy;
1241       end if;
1242
1243       if Length (Left) = 0 then
1244          return Right.Copy;
1245       end if;
1246
1247       C := Length (Left) + Length (Right);
1248       H := Default_Modulus (C);
1249
1250       return S : Set (C, H) do
1251          Difference (Left, Right, S);
1252          Difference (Right, Left, S);
1253       end return;
1254    end Symmetric_Difference;
1255
1256    ------------
1257    -- To_Set --
1258    ------------
1259
1260    function To_Set (New_Item : Element_Type) return Set is
1261       X : Count_Type;
1262       B : Boolean;
1263
1264    begin
1265       return S : Set (Capacity => 1, Modulus => 1) do
1266          Insert (S, New_Item, X, B);
1267          pragma Assert (B);
1268       end return;
1269    end To_Set;
1270
1271    -----------
1272    -- Union --
1273    -----------
1274
1275    procedure Union
1276      (Target : in out Set;
1277       Source : Set)
1278    is
1279       procedure Process (Src_Node : Count_Type);
1280
1281       procedure Iterate is
1282         new HT_Ops.Generic_Iteration (Process);
1283
1284       -------------
1285       -- Process --
1286       -------------
1287
1288       procedure Process (Src_Node : Count_Type) is
1289          N : Node_Type renames Source.Nodes (Src_Node);
1290          E : Element_Type renames N.Element;
1291
1292          X : Count_Type;
1293          B : Boolean;
1294
1295       begin
1296          Insert (Target, E, X, B);
1297       end Process;
1298
1299       --  Start of processing for Union
1300
1301    begin
1302       if Target'Address = Source'Address then
1303          return;
1304       end if;
1305
1306       Iterate (Source);
1307    end Union;
1308
1309    function Union (Left, Right : Set) return Set is
1310       C : Count_Type;
1311       H : Hash_Type;
1312
1313    begin
1314       if Left'Address = Right'Address then
1315          return Left.Copy;
1316       end if;
1317
1318       if Length (Right) = 0 then
1319          return Left.Copy;
1320       end if;
1321
1322       if Length (Left) = 0 then
1323          return Right.Copy;
1324       end if;
1325
1326       C := Length (Left) + Length (Right);
1327       H := Default_Modulus (C);
1328       return S : Set (C, H) do
1329          Assign (Target => S, Source => Left);
1330          Union (Target => S, Source => Right);
1331       end return;
1332    end Union;
1333
1334    ---------
1335    -- Vet --
1336    ---------
1337
1338    function Vet (Container : Set; Position : Cursor) return Boolean is
1339    begin
1340       if Position.Node = 0 then
1341          return True;
1342       end if;
1343
1344       declare
1345          S : Set renames Container;
1346          N : Nodes_Type renames S.Nodes;
1347          X : Count_Type;
1348
1349       begin
1350          if S.Length = 0 then
1351             return False;
1352          end if;
1353
1354          if Position.Node > N'Last then
1355             return False;
1356          end if;
1357
1358          if N (Position.Node).Next = Position.Node then
1359             return False;
1360          end if;
1361
1362          X := S.Buckets (Element_Keys.Index (S, N (Position.Node).Element));
1363
1364          for J in 1 .. S.Length loop
1365             if X = Position.Node then
1366                return True;
1367             end if;
1368
1369             if X = 0 then
1370                return False;
1371             end if;
1372
1373             if X = N (X).Next then  --  to prevent unnecessary looping
1374                return False;
1375             end if;
1376
1377             X := N (X).Next;
1378          end loop;
1379
1380          return False;
1381       end;
1382    end Vet;
1383
1384    package body Generic_Keys is
1385
1386       -----------------------
1387       -- Local Subprograms --
1388       -----------------------
1389
1390       function Equivalent_Key_Node
1391         (Key  : Key_Type;
1392          Node : Node_Type) return Boolean;
1393       pragma Inline (Equivalent_Key_Node);
1394
1395       --------------------------
1396       -- Local Instantiations --
1397       --------------------------
1398
1399       package Key_Keys is
1400         new Hash_Tables.Generic_Bounded_Keys
1401           (HT_Types        => HT_Types,
1402            Next            => Next,
1403            Set_Next        => Set_Next,
1404            Key_Type        => Key_Type,
1405            Hash            => Hash,
1406            Equivalent_Keys => Equivalent_Key_Node);
1407
1408       --------------
1409       -- Contains --
1410       --------------
1411
1412       function Contains
1413         (Container : Set;
1414          Key       : Key_Type) return Boolean
1415       is
1416       begin
1417          return Find (Container, Key) /= No_Element;
1418       end Contains;
1419
1420       ------------
1421       -- Delete --
1422       ------------
1423
1424       procedure Delete
1425         (Container : in out Set;
1426          Key       : Key_Type)
1427       is
1428          X : Count_Type;
1429
1430       begin
1431          Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
1432
1433          if X = 0 then
1434             raise Constraint_Error with "attempt to delete key not in set";
1435          end if;
1436
1437          Free (Container, X);
1438       end Delete;
1439
1440       -------------
1441       -- Element --
1442       -------------
1443
1444       function Element
1445         (Container : Set;
1446          Key       : Key_Type) return Element_Type
1447       is
1448          Node : constant Count_Type := Find (Container, Key).Node;
1449
1450       begin
1451          if Node = 0 then
1452             raise Constraint_Error with "key not in map";
1453          end if;
1454
1455          return Container.Nodes (Node).Element;
1456       end Element;
1457
1458       -------------------------
1459       -- Equivalent_Key_Node --
1460       -------------------------
1461
1462       function Equivalent_Key_Node
1463         (Key  : Key_Type;
1464          Node : Node_Type) return Boolean
1465       is
1466       begin
1467          return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element));
1468       end Equivalent_Key_Node;
1469
1470       -------------
1471       -- Exclude --
1472       -------------
1473
1474       procedure Exclude
1475         (Container : in out Set;
1476          Key       : Key_Type)
1477       is
1478          X : Count_Type;
1479       begin
1480          Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
1481          Free (Container, X);
1482       end Exclude;
1483
1484       ----------
1485       -- Find --
1486       ----------
1487
1488       function Find
1489         (Container : Set;
1490          Key       : Key_Type) return Cursor
1491       is
1492          Node : constant Count_Type := Key_Keys.Find (Container, Key);
1493       begin
1494          return (if Node = 0 then No_Element else (Node => Node));
1495       end Find;
1496
1497       ---------
1498       -- Key --
1499       ---------
1500
1501       function Key (Container : Set; Position : Cursor) return Key_Type is
1502       begin
1503          if not Has_Element (Container, Position) then
1504             raise Constraint_Error with
1505               "Position cursor has no element";
1506          end if;
1507
1508          pragma Assert
1509            (Vet (Container, Position), "bad cursor in function Key");
1510
1511          declare
1512             N  : Node_Type renames Container.Nodes (Position.Node);
1513          begin
1514             return Key (N.Element);
1515          end;
1516       end Key;
1517
1518       -------------
1519       -- Replace --
1520       -------------
1521
1522       procedure Replace
1523         (Container : in out Set;
1524          Key       : Key_Type;
1525          New_Item  : Element_Type)
1526       is
1527          Node : constant Count_Type := Key_Keys.Find (Container, Key);
1528
1529       begin
1530          if Node = 0 then
1531             raise Constraint_Error with
1532               "attempt to replace key not in set";
1533          end if;
1534
1535          Replace_Element (Container, Node, New_Item);
1536       end Replace;
1537
1538    end Generic_Keys;
1539
1540 end Ada.Containers.Formal_Hashed_Sets;