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