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