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