gcc/ada/a-cbhase.adb

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