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