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