gcc/ada/a-cihase.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                  ADA.CONTAINERS.INDEFINITE_HASHED_SETS                   --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2004-2013, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- This unit was originally developed by Matthew J Heaney.                  --
  28 ------------------------------------------------------------------------------
  29
  30 with Ada.Unchecked_Deallocation;
  31
  32 with Ada.Containers.Hash_Tables.Generic_Operations;
  33 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
  34
  35 with Ada.Containers.Hash_Tables.Generic_Keys;
  36 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
  37
  38 with Ada.Containers.Prime_Numbers;
  39
  40 with System; use type System.Address;
  41
  42 package body Ada.Containers.Indefinite_Hashed_Sets is
  43
  44    -----------------------
  45    -- Local Subprograms --
  46    -----------------------
  47
  48    procedure Assign (Node : Node_Access; Item : Element_Type);
  49    pragma Inline (Assign);
  50
  51    function Copy_Node (Source : Node_Access) return Node_Access;
  52    pragma Inline (Copy_Node);
  53
  54    function Equivalent_Keys
  55      (Key  : Element_Type;
  56       Node : Node_Access) return Boolean;
  57    pragma Inline (Equivalent_Keys);
  58
  59    function Find_Equal_Key
  60      (R_HT   : Hash_Table_Type;
  61       L_Node : Node_Access) return Boolean;
  62
  63    function Find_Equivalent_Key
  64      (R_HT   : Hash_Table_Type;
  65       L_Node : Node_Access) return Boolean;
  66
  67    procedure Free (X : in out Node_Access);
  68
  69    function Hash_Node (Node : Node_Access) return Hash_Type;
  70    pragma Inline (Hash_Node);
  71
  72    procedure Insert
  73      (HT       : in out Hash_Table_Type;
  74       New_Item : Element_Type;
  75       Node     : out Node_Access;
  76       Inserted : out Boolean);
  77
  78    function Is_In (HT  : Hash_Table_Type; Key : Node_Access) return Boolean;
  79    pragma Inline (Is_In);
  80
  81    function Next (Node : Node_Access) return Node_Access;
  82    pragma Inline (Next);
  83
  84    function Read_Node (Stream : not null access Root_Stream_Type'Class)
  85      return Node_Access;
  86    pragma Inline (Read_Node);
  87
  88    procedure Set_Next (Node : Node_Access; Next : Node_Access);
  89    pragma Inline (Set_Next);
  90
  91    function Vet (Position : Cursor) return Boolean;
  92
  93    procedure Write_Node
  94      (Stream : not null access Root_Stream_Type'Class;
  95       Node   : Node_Access);
  96    pragma Inline (Write_Node);
  97
  98    --------------------------
  99    -- Local Instantiations --
 100    --------------------------
 101
 102    procedure Free_Element is
 103      new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
 104
 105    package HT_Ops is new Hash_Tables.Generic_Operations
 106      (HT_Types  => HT_Types,
 107       Hash_Node => Hash_Node,
 108       Next      => Next,
 109       Set_Next  => Set_Next,
 110       Copy_Node => Copy_Node,
 111       Free      => Free);
 112
 113    package Element_Keys is new Hash_Tables.Generic_Keys
 114      (HT_Types        => HT_Types,
 115       Next            => Next,
 116       Set_Next        => Set_Next,
 117       Key_Type        => Element_Type,
 118       Hash            => Hash,
 119       Equivalent_Keys => Equivalent_Keys);
 120
 121    function Is_Equal is
 122       new HT_Ops.Generic_Equal (Find_Equal_Key);
 123
 124    function Is_Equivalent is
 125       new HT_Ops.Generic_Equal (Find_Equivalent_Key);
 126
 127    procedure Read_Nodes is
 128       new HT_Ops.Generic_Read (Read_Node);
 129
 130    procedure Replace_Element is
 131       new Element_Keys.Generic_Replace_Element (Hash_Node, Assign);
 132
 133    procedure Write_Nodes is
 134      new HT_Ops.Generic_Write (Write_Node);
 135
 136    ---------
 137    -- "=" --
 138    ---------
 139
 140    function "=" (Left, Right : Set) return Boolean is
 141    begin
 142       return Is_Equal (Left.HT, Right.HT);
 143    end "=";
 144
 145    ------------
 146    -- Adjust --
 147    ------------
 148
 149    procedure Adjust (Container : in out Set) is
 150    begin
 151       HT_Ops.Adjust (Container.HT);
 152    end Adjust;
 153
 154    procedure Adjust (Control : in out Reference_Control_Type) is
 155    begin
 156       if Control.Container /= null then
 157          declare
 158             HT : Hash_Table_Type renames Control.Container.all.HT;
 159             B : Natural renames HT.Busy;
 160             L : Natural renames HT.Lock;
 161          begin
 162             B := B + 1;
 163             L := L + 1;
 164          end;
 165       end if;
 166    end Adjust;
 167
 168    ------------
 169    -- Assign --
 170    ------------
 171
 172    procedure Assign (Node : Node_Access; Item : Element_Type) is
 173       X : Element_Access := Node.Element;
 174
 175       --  The element allocator may need an accessibility check in the case the
 176       --  actual type is class-wide or has access discriminants (RM 4.8(10.1)
 177       --  and AI12-0035).
 178
 179       pragma Unsuppress (Accessibility_Check);
 180
 181    begin
 182       Node.Element := new Element_Type'(Item);
 183       Free_Element (X);
 184    end Assign;
 185
 186    procedure Assign (Target : in out Set; Source : Set) is
 187    begin
 188       if Target'Address = Source'Address then
 189          return;
 190       else
 191          Target.Clear;
 192          Target.Union (Source);
 193       end if;
 194    end Assign;
 195
 196    --------------
 197    -- Capacity --
 198    --------------
 199
 200    function Capacity (Container : Set) return Count_Type is
 201    begin
 202       return HT_Ops.Capacity (Container.HT);
 203    end Capacity;
 204
 205    -----------
 206    -- Clear --
 207    -----------
 208
 209    procedure Clear (Container : in out Set) is
 210    begin
 211       HT_Ops.Clear (Container.HT);
 212    end Clear;
 213
 214    ------------------------
 215    -- Constant_Reference --
 216    ------------------------
 217
 218    function Constant_Reference
 219      (Container : aliased Set;
 220       Position  : Cursor) return Constant_Reference_Type
 221    is
 222    begin
 223       if Position.Container = null then
 224          raise Constraint_Error with "Position cursor has no element";
 225       end if;
 226
 227       if Position.Container /= Container'Unrestricted_Access then
 228          raise Program_Error with
 229            "Position cursor designates wrong container";
 230       end if;
 231
 232       if Position.Node.Element = null then
 233          raise Program_Error with "Node has no element";
 234       end if;
 235
 236       pragma Assert (Vet (Position), "bad cursor in Constant_Reference");
 237
 238       declare
 239          HT : Hash_Table_Type renames Position.Container.all.HT;
 240          B : Natural renames HT.Busy;
 241          L : Natural renames HT.Lock;
 242       begin
 243          return R : constant Constant_Reference_Type :=
 244            (Element => Position.Node.Element.all'Access,
 245             Control => (Controlled with Container'Unrestricted_Access))
 246          do
 247             B := B + 1;
 248             L := L + 1;
 249          end return;
 250       end;
 251    end Constant_Reference;
 252
 253    --------------
 254    -- Contains --
 255    --------------
 256
 257    function Contains (Container : Set; Item : Element_Type) return Boolean is
 258    begin
 259       return Find (Container, Item) /= No_Element;
 260    end Contains;
 261
 262    ----------
 263    -- Copy --
 264    ----------
 265
 266    function Copy
 267      (Source   : Set;
 268       Capacity : Count_Type := 0) return Set
 269    is
 270       C : Count_Type;
 271
 272    begin
 273       if Capacity = 0 then
 274          C := Source.Length;
 275
 276       elsif Capacity >= Source.Length then
 277          C := Capacity;
 278
 279       else
 280          raise Capacity_Error
 281            with "Requested capacity is less than Source length";
 282       end if;
 283
 284       return Target : Set do
 285          Target.Reserve_Capacity (C);
 286          Target.Assign (Source);
 287       end return;
 288    end Copy;
 289
 290    ---------------
 291    -- Copy_Node --
 292    ---------------
 293
 294    function Copy_Node (Source : Node_Access) return Node_Access is
 295       E : Element_Access := new Element_Type'(Source.Element.all);
 296    begin
 297       return new Node_Type'(Element => E, Next => null);
 298    exception
 299       when others =>
 300          Free_Element (E);
 301          raise;
 302    end Copy_Node;
 303
 304    ------------
 305    -- Delete --
 306    ------------
 307
 308    procedure Delete
 309      (Container : in out Set;
 310       Item      : Element_Type)
 311    is
 312       X : Node_Access;
 313
 314    begin
 315       Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
 316
 317       if X = null then
 318          raise Constraint_Error with "attempt to delete element not in set";
 319       end if;
 320
 321       Free (X);
 322    end Delete;
 323
 324    procedure Delete
 325      (Container : in out Set;
 326       Position  : in out Cursor)
 327    is
 328    begin
 329       if Position.Node = null then
 330          raise Constraint_Error with "Position cursor equals No_Element";
 331       end if;
 332
 333       if Position.Node.Element = null then
 334          raise Program_Error with "Position cursor is bad";
 335       end if;
 336
 337       if Position.Container /= Container'Unrestricted_Access then
 338          raise Program_Error with "Position cursor designates wrong set";
 339       end if;
 340
 341       if Container.HT.Busy > 0 then
 342          raise Program_Error with
 343            "attempt to tamper with cursors (set is busy)";
 344       end if;
 345
 346       pragma Assert (Vet (Position), "Position cursor is bad");
 347
 348       HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
 349
 350       Free (Position.Node);
 351       Position.Container := null;
 352    end Delete;
 353
 354    ----------------
 355    -- Difference --
 356    ----------------
 357
 358    procedure Difference
 359      (Target : in out Set;
 360       Source : Set)
 361    is
 362       Tgt_Node : Node_Access;
 363
 364    begin
 365       if Target'Address = Source'Address then
 366          Clear (Target);
 367          return;
 368       end if;
 369
 370       if Source.HT.Length = 0 then
 371          return;
 372       end if;
 373
 374       if Target.HT.Busy > 0 then
 375          raise Program_Error with
 376            "attempt to tamper with cursors (set is busy)";
 377       end if;
 378
 379       if Source.HT.Length < Target.HT.Length then
 380          declare
 381             Src_Node : Node_Access;
 382
 383          begin
 384             Src_Node := HT_Ops.First (Source.HT);
 385             while Src_Node /= null loop
 386                Tgt_Node := Element_Keys.Find (Target.HT, Src_Node.Element.all);
 387
 388                if Tgt_Node /= null then
 389                   HT_Ops.Delete_Node_Sans_Free (Target.HT, Tgt_Node);
 390                   Free (Tgt_Node);
 391                end if;
 392
 393                Src_Node := HT_Ops.Next (Source.HT, Src_Node);
 394             end loop;
 395          end;
 396
 397       else
 398          Tgt_Node := HT_Ops.First (Target.HT);
 399          while Tgt_Node /= null loop
 400             if Is_In (Source.HT, Tgt_Node) then
 401                declare
 402                   X : Node_Access := Tgt_Node;
 403                begin
 404                   Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
 405                   HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
 406                   Free (X);
 407                end;
 408
 409             else
 410                Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
 411             end if;
 412          end loop;
 413       end if;
 414    end Difference;
 415
 416    function Difference (Left, Right : Set) return Set is
 417       Buckets : HT_Types.Buckets_Access;
 418       Length  : Count_Type;
 419
 420    begin
 421       if Left'Address = Right'Address then
 422          return Empty_Set;
 423       end if;
 424
 425       if Left.Length = 0 then
 426          return Empty_Set;
 427       end if;
 428
 429       if Right.Length = 0 then
 430          return Left;
 431       end if;
 432
 433       declare
 434          Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
 435       begin
 436          Buckets := HT_Ops.New_Buckets (Length => Size);
 437       end;
 438
 439       Length := 0;
 440
 441       Iterate_Left : declare
 442          procedure Process (L_Node : Node_Access);
 443
 444          procedure Iterate is
 445             new HT_Ops.Generic_Iteration (Process);
 446
 447          -------------
 448          -- Process --
 449          -------------
 450
 451          procedure Process (L_Node : Node_Access) is
 452          begin
 453             if not Is_In (Right.HT, L_Node) then
 454                declare
 455                   Src    : Element_Type renames L_Node.Element.all;
 456                   Indx   : constant Hash_Type := Hash (Src) mod Buckets'Length;
 457                   Bucket : Node_Access renames Buckets (Indx);
 458                   Tgt    : Element_Access := new Element_Type'(Src);
 459                begin
 460                   Bucket := new Node_Type'(Tgt, Bucket);
 461                exception
 462                   when others =>
 463                      Free_Element (Tgt);
 464                      raise;
 465                end;
 466
 467                Length := Length + 1;
 468             end if;
 469          end Process;
 470
 471       --  Start of processing for Iterate_Left
 472
 473       begin
 474          Iterate (Left.HT);
 475       exception
 476          when others =>
 477             HT_Ops.Free_Hash_Table (Buckets);
 478             raise;
 479       end Iterate_Left;
 480
 481       return (Controlled with HT => (Buckets, Length, 0, 0));
 482    end Difference;
 483
 484    -------------
 485    -- Element --
 486    -------------
 487
 488    function Element (Position : Cursor) return Element_Type is
 489    begin
 490       if Position.Node = null then
 491          raise Constraint_Error with "Position cursor of equals No_Element";
 492       end if;
 493
 494       if Position.Node.Element = null then  --  handle dangling reference
 495          raise Program_Error with "Position cursor is bad";
 496       end if;
 497
 498       pragma Assert (Vet (Position), "bad cursor in function Element");
 499
 500       return Position.Node.Element.all;
 501    end Element;
 502
 503    ---------------------
 504    -- Equivalent_Sets --
 505    ---------------------
 506
 507    function Equivalent_Sets (Left, Right : Set) return Boolean is
 508    begin
 509       return Is_Equivalent (Left.HT, Right.HT);
 510    end Equivalent_Sets;
 511
 512    -------------------------
 513    -- Equivalent_Elements --
 514    -------------------------
 515
 516    function Equivalent_Elements (Left, Right : Cursor) return Boolean is
 517    begin
 518       if Left.Node = null then
 519          raise Constraint_Error with
 520            "Left cursor of Equivalent_Elements equals No_Element";
 521       end if;
 522
 523       if Right.Node = null then
 524          raise Constraint_Error with
 525            "Right cursor of Equivalent_Elements equals No_Element";
 526       end if;
 527
 528       if Left.Node.Element = null then
 529          raise Program_Error with
 530            "Left cursor of Equivalent_Elements is bad";
 531       end if;
 532
 533       if Right.Node.Element = null then
 534          raise Program_Error with
 535            "Right cursor of Equivalent_Elements is bad";
 536       end if;
 537
 538       pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
 539       pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
 540
 541       return Equivalent_Elements
 542                (Left.Node.Element.all,
 543                 Right.Node.Element.all);
 544    end Equivalent_Elements;
 545
 546    function Equivalent_Elements
 547      (Left  : Cursor;
 548       Right : Element_Type) return Boolean
 549    is
 550    begin
 551       if Left.Node = null then
 552          raise Constraint_Error with
 553            "Left cursor of Equivalent_Elements equals No_Element";
 554       end if;
 555
 556       if Left.Node.Element = null then
 557          raise Program_Error with
 558            "Left cursor of Equivalent_Elements is bad";
 559       end if;
 560
 561       pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Elements");
 562
 563       return Equivalent_Elements (Left.Node.Element.all, Right);
 564    end Equivalent_Elements;
 565
 566    function Equivalent_Elements
 567      (Left  : Element_Type;
 568       Right : Cursor) return Boolean
 569    is
 570    begin
 571       if Right.Node = null then
 572          raise Constraint_Error with
 573            "Right cursor of Equivalent_Elements equals No_Element";
 574       end if;
 575
 576       if Right.Node.Element = null then
 577          raise Program_Error with
 578            "Right cursor of Equivalent_Elements is bad";
 579       end if;
 580
 581       pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Elements");
 582
 583       return Equivalent_Elements (Left, Right.Node.Element.all);
 584    end Equivalent_Elements;
 585
 586    ---------------------
 587    -- Equivalent_Keys --
 588    ---------------------
 589
 590    function Equivalent_Keys
 591      (Key  : Element_Type;
 592       Node : Node_Access) return Boolean
 593    is
 594    begin
 595       return Equivalent_Elements (Key, Node.Element.all);
 596    end Equivalent_Keys;
 597
 598    -------------
 599    -- Exclude --
 600    -------------
 601
 602    procedure Exclude
 603      (Container : in out Set;
 604       Item      : Element_Type)
 605    is
 606       X : Node_Access;
 607    begin
 608       Element_Keys.Delete_Key_Sans_Free (Container.HT, Item, X);
 609       Free (X);
 610    end Exclude;
 611
 612    --------------
 613    -- Finalize --
 614    --------------
 615
 616    procedure Finalize (Container : in out Set) is
 617    begin
 618       HT_Ops.Finalize (Container.HT);
 619    end Finalize;
 620
 621    procedure Finalize (Object : in out Iterator) is
 622    begin
 623       if Object.Container /= null then
 624          declare
 625             B : Natural renames Object.Container.all.HT.Busy;
 626          begin
 627             B := B - 1;
 628          end;
 629       end if;
 630    end Finalize;
 631
 632    procedure Finalize (Control : in out Reference_Control_Type) is
 633    begin
 634       if Control.Container /= null then
 635          declare
 636             HT : Hash_Table_Type renames Control.Container.all.HT;
 637             B : Natural renames HT.Busy;
 638             L : Natural renames HT.Lock;
 639          begin
 640             B := B - 1;
 641             L := L - 1;
 642          end;
 643
 644          Control.Container := null;
 645       end if;
 646    end Finalize;
 647
 648    ----------
 649    -- Find --
 650    ----------
 651
 652    function Find
 653      (Container : Set;
 654       Item      : Element_Type) return Cursor
 655    is
 656       Node : constant Node_Access := Element_Keys.Find (Container.HT, Item);
 657    begin
 658       return (if Node = null then No_Element
 659               else Cursor'(Container'Unrestricted_Access, Node));
 660    end Find;
 661
 662    --------------------
 663    -- Find_Equal_Key --
 664    --------------------
 665
 666    function Find_Equal_Key
 667      (R_HT   : Hash_Table_Type;
 668       L_Node : Node_Access) return Boolean
 669    is
 670       R_Index : constant Hash_Type :=
 671         Element_Keys.Index (R_HT, L_Node.Element.all);
 672
 673       R_Node  : Node_Access := R_HT.Buckets (R_Index);
 674
 675    begin
 676       loop
 677          if R_Node = null then
 678             return False;
 679          end if;
 680
 681          if L_Node.Element.all = R_Node.Element.all then
 682             return True;
 683          end if;
 684
 685          R_Node := Next (R_Node);
 686       end loop;
 687    end Find_Equal_Key;
 688
 689    -------------------------
 690    -- Find_Equivalent_Key --
 691    -------------------------
 692
 693    function Find_Equivalent_Key
 694      (R_HT   : Hash_Table_Type;
 695       L_Node : Node_Access) return Boolean
 696    is
 697       R_Index : constant Hash_Type :=
 698         Element_Keys.Index (R_HT, L_Node.Element.all);
 699
 700       R_Node  : Node_Access := R_HT.Buckets (R_Index);
 701
 702    begin
 703       loop
 704          if R_Node = null then
 705             return False;
 706          end if;
 707
 708          if Equivalent_Elements (L_Node.Element.all, R_Node.Element.all) then
 709             return True;
 710          end if;
 711
 712          R_Node := Next (R_Node);
 713       end loop;
 714    end Find_Equivalent_Key;
 715
 716    -----------
 717    -- First --
 718    -----------
 719
 720    function First (Container : Set) return Cursor is
 721       Node : constant Node_Access := HT_Ops.First (Container.HT);
 722    begin
 723       return (if Node = null then No_Element
 724               else Cursor'(Container'Unrestricted_Access, Node));
 725    end First;
 726
 727    function First (Object : Iterator) return Cursor is
 728    begin
 729       return Object.Container.First;
 730    end First;
 731
 732    ----------
 733    -- Free --
 734    ----------
 735
 736    procedure Free (X : in out Node_Access) is
 737       procedure Deallocate is
 738          new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 739
 740    begin
 741       if X = null then
 742          return;
 743       end if;
 744
 745       X.Next := X;  --  detect mischief (in Vet)
 746
 747       begin
 748          Free_Element (X.Element);
 749       exception
 750          when others =>
 751             X.Element := null;
 752             Deallocate (X);
 753             raise;
 754       end;
 755
 756       Deallocate (X);
 757    end Free;
 758
 759    -----------------
 760    -- Has_Element --
 761    -----------------
 762
 763    function Has_Element (Position : Cursor) return Boolean is
 764    begin
 765       pragma Assert (Vet (Position), "bad cursor in Has_Element");
 766       return Position.Node /= null;
 767    end Has_Element;
 768
 769    ---------------
 770    -- Hash_Node --
 771    ---------------
 772
 773    function Hash_Node (Node : Node_Access) return Hash_Type is
 774    begin
 775       return Hash (Node.Element.all);
 776    end Hash_Node;
 777
 778    -------------
 779    -- Include --
 780    -------------
 781
 782    procedure Include
 783      (Container : in out Set;
 784       New_Item  : Element_Type)
 785    is
 786       Position : Cursor;
 787       Inserted : Boolean;
 788
 789       X : Element_Access;
 790
 791    begin
 792       Insert (Container, New_Item, Position, Inserted);
 793
 794       if not Inserted then
 795          if Container.HT.Lock > 0 then
 796             raise Program_Error with
 797               "attempt to tamper with elements (set is locked)";
 798          end if;
 799
 800          X := Position.Node.Element;
 801
 802          declare
 803             --  The element allocator may need an accessibility check in the
 804             --  case the actual type is class-wide or has access discriminants
 805             --  (see RM 4.8(10.1) and AI12-0035).
 806
 807             pragma Unsuppress (Accessibility_Check);
 808
 809          begin
 810             Position.Node.Element := new Element_Type'(New_Item);
 811          end;
 812
 813          Free_Element (X);
 814       end if;
 815    end Include;
 816
 817    ------------
 818    -- Insert --
 819    ------------
 820
 821    procedure Insert
 822      (Container : in out Set;
 823       New_Item  : Element_Type;
 824       Position  : out Cursor;
 825       Inserted  : out Boolean)
 826    is
 827    begin
 828       Insert (Container.HT, New_Item, Position.Node, Inserted);
 829       Position.Container := Container'Unchecked_Access;
 830    end Insert;
 831
 832    procedure Insert
 833      (Container : in out Set;
 834       New_Item  : Element_Type)
 835    is
 836       Position : Cursor;
 837       pragma Unreferenced (Position);
 838
 839       Inserted : Boolean;
 840
 841    begin
 842       Insert (Container, New_Item, Position, Inserted);
 843
 844       if not Inserted then
 845          raise Constraint_Error with
 846            "attempt to insert element already in set";
 847       end if;
 848    end Insert;
 849
 850    procedure Insert
 851      (HT       : in out Hash_Table_Type;
 852       New_Item : Element_Type;
 853       Node     : out Node_Access;
 854       Inserted : out Boolean)
 855    is
 856       function New_Node (Next : Node_Access) return Node_Access;
 857       pragma Inline (New_Node);
 858
 859       procedure Local_Insert is
 860          new Element_Keys.Generic_Conditional_Insert (New_Node);
 861
 862       --------------
 863       -- New_Node --
 864       --------------
 865
 866       function New_Node (Next : Node_Access) return Node_Access is
 867
 868          --  The element allocator may need an accessibility check in the case
 869          --  the actual type is class-wide or has access discriminants (see
 870          --  RM 4.8(10.1) and AI12-0035).
 871
 872          pragma Unsuppress (Accessibility_Check);
 873
 874          Element : Element_Access := new Element_Type'(New_Item);
 875
 876       begin
 877          return new Node_Type'(Element, Next);
 878
 879       exception
 880          when others =>
 881             Free_Element (Element);
 882             raise;
 883       end New_Node;
 884
 885    --  Start of processing for Insert
 886
 887    begin
 888       if HT_Ops.Capacity (HT) = 0 then
 889          HT_Ops.Reserve_Capacity (HT, 1);
 890       end if;
 891
 892       Local_Insert (HT, New_Item, Node, Inserted);
 893
 894       if Inserted and then HT.Length > HT_Ops.Capacity (HT) then
 895          HT_Ops.Reserve_Capacity (HT, HT.Length);
 896       end if;
 897    end Insert;
 898
 899    ------------------
 900    -- Intersection --
 901    ------------------
 902
 903    procedure Intersection
 904      (Target : in out Set;
 905       Source : Set)
 906    is
 907       Tgt_Node : Node_Access;
 908
 909    begin
 910       if Target'Address = Source'Address then
 911          return;
 912       end if;
 913
 914       if Source.Length = 0 then
 915          Clear (Target);
 916          return;
 917       end if;
 918
 919       if Target.HT.Busy > 0 then
 920          raise Program_Error with
 921            "attempt to tamper with cursors (set is busy)";
 922       end if;
 923
 924       Tgt_Node := HT_Ops.First (Target.HT);
 925       while Tgt_Node /= null loop
 926          if Is_In (Source.HT, Tgt_Node) then
 927             Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
 928
 929          else
 930             declare
 931                X : Node_Access := Tgt_Node;
 932             begin
 933                Tgt_Node := HT_Ops.Next (Target.HT, Tgt_Node);
 934                HT_Ops.Delete_Node_Sans_Free (Target.HT, X);
 935                Free (X);
 936             end;
 937          end if;
 938       end loop;
 939    end Intersection;
 940
 941    function Intersection (Left, Right : Set) return Set is
 942       Buckets : HT_Types.Buckets_Access;
 943       Length  : Count_Type;
 944
 945    begin
 946       if Left'Address = Right'Address then
 947          return Left;
 948       end if;
 949
 950       Length := Count_Type'Min (Left.Length, Right.Length);
 951
 952       if Length = 0 then
 953          return Empty_Set;
 954       end if;
 955
 956       declare
 957          Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
 958       begin
 959          Buckets := HT_Ops.New_Buckets (Length => Size);
 960       end;
 961
 962       Length := 0;
 963
 964       Iterate_Left : declare
 965          procedure Process (L_Node : Node_Access);
 966
 967          procedure Iterate is
 968             new HT_Ops.Generic_Iteration (Process);
 969
 970          -------------
 971          -- Process --
 972          -------------
 973
 974          procedure Process (L_Node : Node_Access) is
 975          begin
 976             if Is_In (Right.HT, L_Node) then
 977                declare
 978                   Src : Element_Type renames L_Node.Element.all;
 979
 980                   Indx : constant Hash_Type := Hash (Src) mod Buckets'Length;
 981
 982                   Bucket : Node_Access renames Buckets (Indx);
 983
 984                   Tgt : Element_Access := new Element_Type'(Src);
 985
 986                begin
 987                   Bucket := new Node_Type'(Tgt, Bucket);
 988                exception
 989                   when others =>
 990                      Free_Element (Tgt);
 991                      raise;
 992                end;
 993
 994                Length := Length + 1;
 995             end if;
 996          end Process;
 997
 998       --  Start of processing for Iterate_Left
 999
1000       begin
1001          Iterate (Left.HT);
1002       exception
1003          when others =>
1004             HT_Ops.Free_Hash_Table (Buckets);
1005             raise;
1006       end Iterate_Left;
1007
1008       return (Controlled with HT => (Buckets, Length, 0, 0));
1009    end Intersection;
1010
1011    --------------
1012    -- Is_Empty --
1013    --------------
1014
1015    function Is_Empty (Container : Set) return Boolean is
1016    begin
1017       return Container.HT.Length = 0;
1018    end Is_Empty;
1019
1020    -----------
1021    -- Is_In --
1022    -----------
1023
1024    function Is_In (HT  : Hash_Table_Type; Key : Node_Access) return Boolean is
1025    begin
1026       return Element_Keys.Find (HT, Key.Element.all) /= null;
1027    end Is_In;
1028
1029    ---------------
1030    -- Is_Subset --
1031    ---------------
1032
1033    function Is_Subset
1034      (Subset : Set;
1035       Of_Set : Set) return Boolean
1036    is
1037       Subset_Node : Node_Access;
1038
1039    begin
1040       if Subset'Address = Of_Set'Address then
1041          return True;
1042       end if;
1043
1044       if Subset.Length > Of_Set.Length then
1045          return False;
1046       end if;
1047
1048       Subset_Node := HT_Ops.First (Subset.HT);
1049       while Subset_Node /= null loop
1050          if not Is_In (Of_Set.HT, Subset_Node) then
1051             return False;
1052          end if;
1053
1054          Subset_Node := HT_Ops.Next (Subset.HT, Subset_Node);
1055       end loop;
1056
1057       return True;
1058    end Is_Subset;
1059
1060    -------------
1061    -- Iterate --
1062    -------------
1063
1064    procedure Iterate
1065      (Container : Set;
1066       Process   : not null access procedure (Position : Cursor))
1067    is
1068       procedure Process_Node (Node : Node_Access);
1069       pragma Inline (Process_Node);
1070
1071       procedure Iterate is
1072          new HT_Ops.Generic_Iteration (Process_Node);
1073
1074       ------------------
1075       -- Process_Node --
1076       ------------------
1077
1078       procedure Process_Node (Node : Node_Access) is
1079       begin
1080          Process (Cursor'(Container'Unrestricted_Access, Node));
1081       end Process_Node;
1082
1083       B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
1084
1085    --  Start of processing for Iterate
1086
1087    begin
1088       B := B + 1;
1089
1090       begin
1091          Iterate (Container.HT);
1092       exception
1093          when others =>
1094             B := B - 1;
1095             raise;
1096       end;
1097
1098       B := B - 1;
1099    end Iterate;
1100
1101    function Iterate (Container : Set)
1102      return Set_Iterator_Interfaces.Forward_Iterator'Class
1103    is
1104       B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
1105    begin
1106       return It : constant Iterator :=
1107         Iterator'(Limited_Controlled with
1108                     Container => Container'Unrestricted_Access)
1109       do
1110          B := B + 1;
1111       end return;
1112    end Iterate;
1113
1114    ------------
1115    -- Length --
1116    ------------
1117
1118    function Length (Container : Set) return Count_Type is
1119    begin
1120       return Container.HT.Length;
1121    end Length;
1122
1123    ----------
1124    -- Move --
1125    ----------
1126
1127    procedure Move (Target : in out Set; Source : in out Set) is
1128    begin
1129       HT_Ops.Move (Target => Target.HT, Source => Source.HT);
1130    end Move;
1131
1132    ----------
1133    -- Next --
1134    ----------
1135
1136    function Next (Node : Node_Access) return Node_Access is
1137    begin
1138       return Node.Next;
1139    end Next;
1140
1141    function Next (Position : Cursor) return Cursor is
1142    begin
1143       if Position.Node = null then
1144          return No_Element;
1145       end if;
1146
1147       if Position.Node.Element = null then
1148          raise Program_Error with "bad cursor in Next";
1149       end if;
1150
1151       pragma Assert (Vet (Position), "bad cursor in Next");
1152
1153       declare
1154          HT   : Hash_Table_Type renames Position.Container.HT;
1155          Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
1156       begin
1157          return (if Node = null then No_Element
1158                  else Cursor'(Position.Container, Node));
1159       end;
1160    end Next;
1161
1162    procedure Next (Position : in out Cursor) is
1163    begin
1164       Position := Next (Position);
1165    end Next;
1166
1167    function Next
1168      (Object   : Iterator;
1169       Position : Cursor) return Cursor
1170    is
1171    begin
1172       if Position.Container = null then
1173          return No_Element;
1174       end if;
1175
1176       if Position.Container /= Object.Container then
1177          raise Program_Error with
1178            "Position cursor of Next designates wrong set";
1179       end if;
1180
1181       return Next (Position);
1182    end Next;
1183
1184    -------------
1185    -- Overlap --
1186    -------------
1187
1188    function Overlap (Left, Right : Set) return Boolean is
1189       Left_Node : Node_Access;
1190
1191    begin
1192       if Right.Length = 0 then
1193          return False;
1194       end if;
1195
1196       if Left'Address = Right'Address then
1197          return True;
1198       end if;
1199
1200       Left_Node := HT_Ops.First (Left.HT);
1201       while Left_Node /= null loop
1202          if Is_In (Right.HT, Left_Node) then
1203             return True;
1204          end if;
1205
1206          Left_Node := HT_Ops.Next (Left.HT, Left_Node);
1207       end loop;
1208
1209       return False;
1210    end Overlap;
1211
1212    -------------------
1213    -- Query_Element --
1214    -------------------
1215
1216    procedure Query_Element
1217      (Position : Cursor;
1218       Process  : not null access procedure (Element : Element_Type))
1219    is
1220    begin
1221       if Position.Node = null then
1222          raise Constraint_Error with
1223            "Position cursor of Query_Element equals No_Element";
1224       end if;
1225
1226       if Position.Node.Element = null then
1227          raise Program_Error with "bad cursor in Query_Element";
1228       end if;
1229
1230       pragma Assert (Vet (Position), "bad cursor in Query_Element");
1231
1232       declare
1233          HT : Hash_Table_Type renames
1234                 Position.Container'Unrestricted_Access.all.HT;
1235
1236          B : Natural renames HT.Busy;
1237          L : Natural renames HT.Lock;
1238
1239       begin
1240          B := B + 1;
1241          L := L + 1;
1242
1243          begin
1244             Process (Position.Node.Element.all);
1245          exception
1246             when others =>
1247                L := L - 1;
1248                B := B - 1;
1249                raise;
1250          end;
1251
1252          L := L - 1;
1253          B := B - 1;
1254       end;
1255    end Query_Element;
1256
1257    ----------
1258    -- Read --
1259    ----------
1260
1261    procedure Read
1262      (Stream    : not null access Root_Stream_Type'Class;
1263       Container : out Set)
1264    is
1265    begin
1266       Read_Nodes (Stream, Container.HT);
1267    end Read;
1268
1269    procedure Read
1270      (Stream : not null access Root_Stream_Type'Class;
1271       Item   : out Cursor)
1272    is
1273    begin
1274       raise Program_Error with "attempt to stream set cursor";
1275    end Read;
1276
1277    procedure Read
1278      (Stream : not null access Root_Stream_Type'Class;
1279       Item   : out Constant_Reference_Type)
1280    is
1281    begin
1282       raise Program_Error with "attempt to stream reference";
1283    end Read;
1284
1285    ---------------
1286    -- Read_Node --
1287    ---------------
1288
1289    function Read_Node
1290      (Stream : not null access Root_Stream_Type'Class) return Node_Access
1291    is
1292       X : Element_Access := new Element_Type'(Element_Type'Input (Stream));
1293    begin
1294       return new Node_Type'(X, null);
1295    exception
1296       when others =>
1297          Free_Element (X);
1298          raise;
1299    end Read_Node;
1300
1301    -------------
1302    -- Replace --
1303    -------------
1304
1305    procedure Replace
1306      (Container : in out Set;
1307       New_Item  : Element_Type)
1308    is
1309       Node : constant Node_Access :=
1310         Element_Keys.Find (Container.HT, New_Item);
1311
1312       X : Element_Access;
1313       pragma Warnings (Off, X);
1314
1315    begin
1316       if Node = null then
1317          raise Constraint_Error with
1318            "attempt to replace element not in set";
1319       end if;
1320
1321       if Container.HT.Lock > 0 then
1322          raise Program_Error with
1323            "attempt to tamper with elements (set is locked)";
1324       end if;
1325
1326       X := Node.Element;
1327
1328       declare
1329          --  The element allocator may need an accessibility check in the case
1330          --  the actual type is class-wide or has access discriminants (see
1331          --  RM 4.8(10.1) and AI12-0035).
1332
1333          pragma Unsuppress (Accessibility_Check);
1334
1335       begin
1336          Node.Element := new Element_Type'(New_Item);
1337       end;
1338
1339       Free_Element (X);
1340    end Replace;
1341
1342    ---------------------
1343    -- Replace_Element --
1344    ---------------------
1345
1346    procedure Replace_Element
1347      (Container : in out Set;
1348       Position  : Cursor;
1349       New_Item  : Element_Type)
1350    is
1351    begin
1352       if Position.Node = null then
1353          raise Constraint_Error with "Position cursor equals No_Element";
1354       end if;
1355
1356       if Position.Node.Element = null then
1357          raise Program_Error with "bad cursor in Replace_Element";
1358       end if;
1359
1360       if Position.Container /= Container'Unrestricted_Access then
1361          raise Program_Error with
1362            "Position cursor designates wrong set";
1363       end if;
1364
1365       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1366
1367       Replace_Element (Container.HT, Position.Node, New_Item);
1368    end Replace_Element;
1369
1370    ----------------------
1371    -- Reserve_Capacity --
1372    ----------------------
1373
1374    procedure Reserve_Capacity
1375      (Container : in out Set;
1376       Capacity  : Count_Type)
1377    is
1378    begin
1379       HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1380    end Reserve_Capacity;
1381
1382    --------------
1383    -- Set_Next --
1384    --------------
1385
1386    procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1387    begin
1388       Node.Next := Next;
1389    end Set_Next;
1390
1391    --------------------------
1392    -- Symmetric_Difference --
1393    --------------------------
1394
1395    procedure Symmetric_Difference
1396      (Target : in out Set;
1397       Source : Set)
1398    is
1399    begin
1400       if Target'Address = Source'Address then
1401          Clear (Target);
1402          return;
1403       end if;
1404
1405       if Target.HT.Busy > 0 then
1406          raise Program_Error with
1407            "attempt to tamper with cursors (set is busy)";
1408       end if;
1409
1410       declare
1411          N : constant Count_Type := Target.Length + Source.Length;
1412       begin
1413          if N > HT_Ops.Capacity (Target.HT) then
1414             HT_Ops.Reserve_Capacity (Target.HT, N);
1415          end if;
1416       end;
1417
1418       if Target.Length = 0 then
1419          Iterate_Source_When_Empty_Target : declare
1420             procedure Process (Src_Node : Node_Access);
1421
1422             procedure Iterate is new HT_Ops.Generic_Iteration (Process);
1423
1424             -------------
1425             -- Process --
1426             -------------
1427
1428             procedure Process (Src_Node : Node_Access) is
1429                E : Element_Type renames Src_Node.Element.all;
1430                B : Buckets_Type renames Target.HT.Buckets.all;
1431                J : constant Hash_Type := Hash (E) mod B'Length;
1432                N : Count_Type renames Target.HT.Length;
1433
1434             begin
1435                declare
1436                   X : Element_Access := new Element_Type'(E);
1437                begin
1438                   B (J) := new Node_Type'(X, B (J));
1439                exception
1440                   when others =>
1441                      Free_Element (X);
1442                      raise;
1443                end;
1444
1445                N := N + 1;
1446             end Process;
1447
1448          --  Start of processing for Iterate_Source_When_Empty_Target
1449
1450          begin
1451             Iterate (Source.HT);
1452          end Iterate_Source_When_Empty_Target;
1453
1454       else
1455          Iterate_Source : declare
1456             procedure Process (Src_Node : Node_Access);
1457
1458             procedure Iterate is
1459                new HT_Ops.Generic_Iteration (Process);
1460
1461             -------------
1462             -- Process --
1463             -------------
1464
1465             procedure Process (Src_Node : Node_Access) is
1466                E : Element_Type renames Src_Node.Element.all;
1467                B : Buckets_Type renames Target.HT.Buckets.all;
1468                J : constant Hash_Type := Hash (E) mod B'Length;
1469                N : Count_Type renames Target.HT.Length;
1470
1471             begin
1472                if B (J) = null then
1473                   declare
1474                      X : Element_Access := new Element_Type'(E);
1475                   begin
1476                      B (J) := new Node_Type'(X, null);
1477                   exception
1478                      when others =>
1479                         Free_Element (X);
1480                         raise;
1481                   end;
1482
1483                   N := N + 1;
1484
1485                elsif Equivalent_Elements (E, B (J).Element.all) then
1486                   declare
1487                      X : Node_Access := B (J);
1488                   begin
1489                      B (J) := B (J).Next;
1490                      N := N - 1;
1491                      Free (X);
1492                   end;
1493
1494                else
1495                   declare
1496                      Prev : Node_Access := B (J);
1497                      Curr : Node_Access := Prev.Next;
1498
1499                   begin
1500                      while Curr /= null loop
1501                         if Equivalent_Elements (E, Curr.Element.all) then
1502                            Prev.Next := Curr.Next;
1503                            N := N - 1;
1504                            Free (Curr);
1505                            return;
1506                         end if;
1507
1508                         Prev := Curr;
1509                         Curr := Prev.Next;
1510                      end loop;
1511
1512                      declare
1513                         X : Element_Access := new Element_Type'(E);
1514                      begin
1515                         B (J) := new Node_Type'(X, B (J));
1516                      exception
1517                         when others =>
1518                            Free_Element (X);
1519                            raise;
1520                      end;
1521
1522                      N := N + 1;
1523                   end;
1524                end if;
1525             end Process;
1526
1527          --  Start of processing for Iterate_Source
1528
1529          begin
1530             Iterate (Source.HT);
1531          end Iterate_Source;
1532       end if;
1533    end Symmetric_Difference;
1534
1535    function Symmetric_Difference (Left, Right : Set) return Set is
1536       Buckets : HT_Types.Buckets_Access;
1537       Length  : Count_Type;
1538
1539    begin
1540       if Left'Address = Right'Address then
1541          return Empty_Set;
1542       end if;
1543
1544       if Right.Length = 0 then
1545          return Left;
1546       end if;
1547
1548       if Left.Length = 0 then
1549          return Right;
1550       end if;
1551
1552       declare
1553          Size : constant Hash_Type :=
1554            Prime_Numbers.To_Prime (Left.Length + Right.Length);
1555       begin
1556          Buckets := HT_Ops.New_Buckets (Length => Size);
1557       end;
1558
1559       Length := 0;
1560
1561       Iterate_Left : declare
1562          procedure Process (L_Node : Node_Access);
1563
1564          procedure Iterate is
1565             new HT_Ops.Generic_Iteration (Process);
1566
1567          -------------
1568          -- Process --
1569          -------------
1570
1571          procedure Process (L_Node : Node_Access) is
1572          begin
1573             if not Is_In (Right.HT, L_Node) then
1574                declare
1575                   E : Element_Type renames L_Node.Element.all;
1576                   J : constant Hash_Type := Hash (E) mod Buckets'Length;
1577
1578                begin
1579                   declare
1580                      X : Element_Access := new Element_Type'(E);
1581                   begin
1582                      Buckets (J) := new Node_Type'(X, Buckets (J));
1583                   exception
1584                      when others =>
1585                         Free_Element (X);
1586                         raise;
1587                   end;
1588
1589                   Length := Length + 1;
1590                end;
1591             end if;
1592          end Process;
1593
1594       --  Start of processing for Iterate_Left
1595
1596       begin
1597          Iterate (Left.HT);
1598       exception
1599          when others =>
1600             HT_Ops.Free_Hash_Table (Buckets);
1601             raise;
1602       end Iterate_Left;
1603
1604       Iterate_Right : declare
1605          procedure Process (R_Node : Node_Access);
1606
1607          procedure Iterate is
1608             new HT_Ops.Generic_Iteration (Process);
1609
1610          -------------
1611          -- Process --
1612          -------------
1613
1614          procedure Process (R_Node : Node_Access) is
1615          begin
1616             if not Is_In (Left.HT, R_Node) then
1617                declare
1618                   E : Element_Type renames R_Node.Element.all;
1619                   J : constant Hash_Type := Hash (E) mod Buckets'Length;
1620
1621                begin
1622                   declare
1623                      X : Element_Access := new Element_Type'(E);
1624                   begin
1625                      Buckets (J) := new Node_Type'(X, Buckets (J));
1626                   exception
1627                      when others =>
1628                         Free_Element (X);
1629                         raise;
1630                   end;
1631
1632                   Length := Length + 1;
1633                end;
1634             end if;
1635          end Process;
1636
1637       --  Start of processing for Iterate_Right
1638
1639       begin
1640          Iterate (Right.HT);
1641       exception
1642          when others =>
1643             HT_Ops.Free_Hash_Table (Buckets);
1644             raise;
1645       end Iterate_Right;
1646
1647       return (Controlled with HT => (Buckets, Length, 0, 0));
1648    end Symmetric_Difference;
1649
1650    ------------
1651    -- To_Set --
1652    ------------
1653
1654    function To_Set (New_Item : Element_Type) return Set is
1655       HT       : Hash_Table_Type;
1656       Node     : Node_Access;
1657       Inserted : Boolean;
1658       pragma Unreferenced (Node, Inserted);
1659    begin
1660       Insert (HT, New_Item, Node, Inserted);
1661       return Set'(Controlled with HT);
1662    end To_Set;
1663
1664    -----------
1665    -- Union --
1666    -----------
1667
1668    procedure Union
1669      (Target : in out Set;
1670       Source : Set)
1671    is
1672       procedure Process (Src_Node : Node_Access);
1673
1674       procedure Iterate is
1675          new HT_Ops.Generic_Iteration (Process);
1676
1677       -------------
1678       -- Process --
1679       -------------
1680
1681       procedure Process (Src_Node : Node_Access) is
1682          Src : Element_Type renames Src_Node.Element.all;
1683
1684          function New_Node (Next : Node_Access) return Node_Access;
1685          pragma Inline (New_Node);
1686
1687          procedure Insert is
1688             new Element_Keys.Generic_Conditional_Insert (New_Node);
1689
1690          --------------
1691          -- New_Node --
1692          --------------
1693
1694          function New_Node (Next : Node_Access) return Node_Access is
1695             Tgt : Element_Access := new Element_Type'(Src);
1696          begin
1697             return new Node_Type'(Tgt, Next);
1698          exception
1699             when others =>
1700                Free_Element (Tgt);
1701                raise;
1702          end New_Node;
1703
1704          Tgt_Node : Node_Access;
1705          Success  : Boolean;
1706          pragma Unreferenced (Tgt_Node, Success);
1707
1708       --  Start of processing for Process
1709
1710       begin
1711          Insert (Target.HT, Src, Tgt_Node, Success);
1712       end Process;
1713
1714    --  Start of processing for Union
1715
1716    begin
1717       if Target'Address = Source'Address then
1718          return;
1719       end if;
1720
1721       if Target.HT.Busy > 0 then
1722          raise Program_Error with
1723            "attempt to tamper with cursors (set is busy)";
1724       end if;
1725
1726       declare
1727          N : constant Count_Type := Target.Length + Source.Length;
1728       begin
1729          if N > HT_Ops.Capacity (Target.HT) then
1730             HT_Ops.Reserve_Capacity (Target.HT, N);
1731          end if;
1732       end;
1733
1734       Iterate (Source.HT);
1735    end Union;
1736
1737    function Union (Left, Right : Set) return Set is
1738       Buckets : HT_Types.Buckets_Access;
1739       Length  : Count_Type;
1740
1741    begin
1742       if Left'Address = Right'Address then
1743          return Left;
1744       end if;
1745
1746       if Right.Length = 0 then
1747          return Left;
1748       end if;
1749
1750       if Left.Length = 0 then
1751          return Right;
1752       end if;
1753
1754       declare
1755          Size : constant Hash_Type :=
1756            Prime_Numbers.To_Prime (Left.Length + Right.Length);
1757       begin
1758          Buckets := HT_Ops.New_Buckets (Length => Size);
1759       end;
1760
1761       Iterate_Left : declare
1762          procedure Process (L_Node : Node_Access);
1763
1764          procedure Iterate is
1765             new HT_Ops.Generic_Iteration (Process);
1766
1767          -------------
1768          -- Process --
1769          -------------
1770
1771          procedure Process (L_Node : Node_Access) is
1772             Src    : Element_Type renames L_Node.Element.all;
1773             J      : constant Hash_Type := Hash (Src) mod Buckets'Length;
1774             Bucket : Node_Access renames Buckets (J);
1775             Tgt    : Element_Access := new Element_Type'(Src);
1776          begin
1777             Bucket := new Node_Type'(Tgt, Bucket);
1778          exception
1779             when others =>
1780                Free_Element (Tgt);
1781                raise;
1782          end Process;
1783
1784       --  Start of processing for Process
1785
1786       begin
1787          Iterate (Left.HT);
1788       exception
1789          when others =>
1790             HT_Ops.Free_Hash_Table (Buckets);
1791             raise;
1792       end Iterate_Left;
1793
1794       Length := Left.Length;
1795
1796       Iterate_Right : declare
1797          procedure Process (Src_Node : Node_Access);
1798
1799          procedure Iterate is
1800             new HT_Ops.Generic_Iteration (Process);
1801
1802          -------------
1803          -- Process --
1804          -------------
1805
1806          procedure Process (Src_Node : Node_Access) is
1807             Src : Element_Type renames Src_Node.Element.all;
1808             Idx : constant Hash_Type := Hash (Src) mod Buckets'Length;
1809
1810             Tgt_Node : Node_Access := Buckets (Idx);
1811
1812          begin
1813             while Tgt_Node /= null loop
1814                if Equivalent_Elements (Src, Tgt_Node.Element.all) then
1815                   return;
1816                end if;
1817                Tgt_Node := Next (Tgt_Node);
1818             end loop;
1819
1820             declare
1821                Tgt : Element_Access := new Element_Type'(Src);
1822             begin
1823                Buckets (Idx) := new Node_Type'(Tgt, Buckets (Idx));
1824             exception
1825                when others =>
1826                   Free_Element (Tgt);
1827                   raise;
1828             end;
1829
1830             Length := Length + 1;
1831          end Process;
1832
1833       --  Start of processing for Iterate_Right
1834
1835       begin
1836          Iterate (Right.HT);
1837       exception
1838          when others =>
1839             HT_Ops.Free_Hash_Table (Buckets);
1840             raise;
1841       end Iterate_Right;
1842
1843       return (Controlled with HT => (Buckets, Length, 0, 0));
1844    end Union;
1845
1846    ---------
1847    -- Vet --
1848    ---------
1849
1850    function Vet (Position : Cursor) return Boolean is
1851    begin
1852       if Position.Node = null then
1853          return Position.Container = null;
1854       end if;
1855
1856       if Position.Container = null then
1857          return False;
1858       end if;
1859
1860       if Position.Node.Next = Position.Node then
1861          return False;
1862       end if;
1863
1864       if Position.Node.Element = null then
1865          return False;
1866       end if;
1867
1868       declare
1869          HT : Hash_Table_Type renames Position.Container.HT;
1870          X  : Node_Access;
1871
1872       begin
1873          if HT.Length = 0 then
1874             return False;
1875          end if;
1876
1877          if HT.Buckets = null
1878            or else HT.Buckets'Length = 0
1879          then
1880             return False;
1881          end if;
1882
1883          X := HT.Buckets (Element_Keys.Index (HT, Position.Node.Element.all));
1884
1885          for J in 1 .. HT.Length loop
1886             if X = Position.Node then
1887                return True;
1888             end if;
1889
1890             if X = null then
1891                return False;
1892             end if;
1893
1894             if X = X.Next then  --  to prevent unnecessary looping
1895                return False;
1896             end if;
1897
1898             X := X.Next;
1899          end loop;
1900
1901          return False;
1902       end;
1903    end Vet;
1904
1905    -----------
1906    -- Write --
1907    -----------
1908
1909    procedure Write
1910      (Stream    : not null access Root_Stream_Type'Class;
1911       Container : Set)
1912    is
1913    begin
1914       Write_Nodes (Stream, Container.HT);
1915    end Write;
1916
1917    procedure Write
1918      (Stream : not null access Root_Stream_Type'Class;
1919       Item   : Cursor)
1920    is
1921    begin
1922       raise Program_Error with "attempt to stream set cursor";
1923    end Write;
1924
1925    procedure Write
1926      (Stream : not null access Root_Stream_Type'Class;
1927       Item   : Constant_Reference_Type)
1928    is
1929    begin
1930       raise Program_Error with "attempt to stream reference";
1931    end Write;
1932
1933    ----------------
1934    -- Write_Node --
1935    ----------------
1936
1937    procedure Write_Node
1938      (Stream : not null access Root_Stream_Type'Class;
1939       Node   : Node_Access)
1940    is
1941    begin
1942       Element_Type'Output (Stream, Node.Element.all);
1943    end Write_Node;
1944
1945    package body Generic_Keys is
1946
1947       -----------------------
1948       -- Local Subprograms --
1949       -----------------------
1950
1951       function Equivalent_Key_Node
1952         (Key  : Key_Type;
1953          Node : Node_Access) return Boolean;
1954       pragma Inline (Equivalent_Key_Node);
1955
1956       --------------------------
1957       -- Local Instantiations --
1958       --------------------------
1959
1960       package Key_Keys is
1961          new Hash_Tables.Generic_Keys
1962           (HT_Types  => HT_Types,
1963            Next      => Next,
1964            Set_Next  => Set_Next,
1965            Key_Type  => Key_Type,
1966            Hash      => Hash,
1967            Equivalent_Keys => Equivalent_Key_Node);
1968
1969       ------------------------
1970       -- Constant_Reference --
1971       ------------------------
1972
1973       function Constant_Reference
1974         (Container : aliased Set;
1975          Key       : Key_Type) return Constant_Reference_Type
1976       is
1977          Node : constant Node_Access :=
1978            Key_Keys.Find (Container.HT, Key);
1979
1980       begin
1981          if Node = null then
1982             raise Constraint_Error with "Key not in set";
1983          end if;
1984
1985          if Node.Element = null then
1986             raise Program_Error with "Node has no element";
1987          end if;
1988
1989          declare
1990             HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
1991             B : Natural renames HT.Busy;
1992             L : Natural renames HT.Lock;
1993          begin
1994             return R : constant Constant_Reference_Type :=
1995               (Element => Node.Element.all'Access,
1996                Control => (Controlled with Container'Unrestricted_Access))
1997             do
1998                B := B + 1;
1999                L := L + 1;
2000             end return;
2001          end;
2002       end Constant_Reference;
2003
2004       --------------
2005       -- Contains --
2006       --------------
2007
2008       function Contains
2009         (Container : Set;
2010          Key       : Key_Type) return Boolean
2011       is
2012       begin
2013          return Find (Container, Key) /= No_Element;
2014       end Contains;
2015
2016       ------------
2017       -- Delete --
2018       ------------
2019
2020       procedure Delete
2021         (Container : in out Set;
2022          Key       : Key_Type)
2023       is
2024          X : Node_Access;
2025
2026       begin
2027          Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
2028
2029          if X = null then
2030             raise Constraint_Error with "key not in map";  --  ??? "set"
2031          end if;
2032
2033          Free (X);
2034       end Delete;
2035
2036       -------------
2037       -- Element --
2038       -------------
2039
2040       function Element
2041         (Container : Set;
2042          Key       : Key_Type) return Element_Type
2043       is
2044          Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
2045
2046       begin
2047          if Node = null then
2048             raise Constraint_Error with "key not in map";  --  ??? "set"
2049          end if;
2050
2051          return Node.Element.all;
2052       end Element;
2053
2054       -------------------------
2055       -- Equivalent_Key_Node --
2056       -------------------------
2057
2058       function Equivalent_Key_Node
2059         (Key  : Key_Type;
2060          Node : Node_Access) return Boolean is
2061       begin
2062          return Equivalent_Keys (Key, Generic_Keys.Key (Node.Element.all));
2063       end Equivalent_Key_Node;
2064
2065       -------------
2066       -- Exclude --
2067       -------------
2068
2069       procedure Exclude
2070         (Container : in out Set;
2071          Key       : Key_Type)
2072       is
2073          X : Node_Access;
2074       begin
2075          Key_Keys.Delete_Key_Sans_Free (Container.HT, Key, X);
2076          Free (X);
2077       end Exclude;
2078
2079       ----------
2080       -- Find --
2081       ----------
2082
2083       function Find
2084         (Container : Set;
2085          Key       : Key_Type) return Cursor
2086       is
2087          Node : constant Node_Access := Key_Keys.Find (Container.HT, Key);
2088       begin
2089          return (if Node = null then No_Element
2090                  else Cursor'(Container'Unrestricted_Access, Node));
2091       end Find;
2092
2093       ---------
2094       -- Key --
2095       ---------
2096
2097       function Key (Position : Cursor) return Key_Type is
2098       begin
2099          if Position.Node = null then
2100             raise Constraint_Error with
2101               "Position cursor equals No_Element";
2102          end if;
2103
2104          if Position.Node.Element = null then
2105             raise Program_Error with "Position cursor is bad";
2106          end if;
2107
2108          pragma Assert (Vet (Position), "bad cursor in function Key");
2109
2110          return Key (Position.Node.Element.all);
2111       end Key;
2112
2113       ----------
2114       -- Read --
2115       ----------
2116
2117       procedure Read
2118         (Stream : not null access Root_Stream_Type'Class;
2119          Item   : out Reference_Type)
2120       is
2121       begin
2122          raise Program_Error with "attempt to stream reference";
2123       end Read;
2124
2125       ------------------------------
2126       -- Reference_Preserving_Key --
2127       ------------------------------
2128
2129       function Reference_Preserving_Key
2130         (Container : aliased in out Set;
2131          Position  : Cursor) return Reference_Type
2132       is
2133       begin
2134          if Position.Container = null then
2135             raise Constraint_Error with "Position cursor has no element";
2136          end if;
2137
2138          if Position.Container /= Container'Unrestricted_Access then
2139             raise Program_Error with
2140               "Position cursor designates wrong container";
2141          end if;
2142
2143          if Position.Node.Element = null then
2144             raise Program_Error with "Node has no element";
2145          end if;
2146
2147          pragma Assert
2148            (Vet (Position),
2149             "bad cursor in function Reference_Preserving_Key");
2150
2151          --  Some form of finalization will be required in order to actually
2152          --  check that the key-part of the element designated by Position has
2153          --  not changed.  ???
2154
2155          return (Element => Position.Node.Element.all'Access);
2156       end Reference_Preserving_Key;
2157
2158       function Reference_Preserving_Key
2159         (Container : aliased in out Set;
2160          Key       : Key_Type) return Reference_Type
2161       is
2162          Node : constant Node_Access :=
2163            Key_Keys.Find (Container.HT, Key);
2164
2165       begin
2166          if Node = null then
2167             raise Constraint_Error with "Key not in set";
2168          end if;
2169
2170          if Node.Element = null then
2171             raise Program_Error with "Node has no element";
2172          end if;
2173
2174          --  Some form of finalization will be required in order to actually
2175          --  check that the key-part of the element designated by Key has not
2176          --  changed.  ???
2177
2178          return (Element => Node.Element.all'Access);
2179       end Reference_Preserving_Key;
2180
2181       -------------
2182       -- Replace --
2183       -------------
2184
2185       procedure Replace
2186         (Container : in out Set;
2187          Key       : Key_Type;
2188          New_Item  : Element_Type)
2189       is
2190          Node : constant Node_Access :=
2191            Key_Keys.Find (Container.HT, Key);
2192
2193       begin
2194          if Node = null then
2195             raise Constraint_Error with
2196               "attempt to replace key not in set";
2197          end if;
2198
2199          Replace_Element (Container.HT, Node, New_Item);
2200       end Replace;
2201
2202       -----------------------------------
2203       -- Update_Element_Preserving_Key --
2204       -----------------------------------
2205
2206       procedure Update_Element_Preserving_Key
2207         (Container : in out Set;
2208          Position  : Cursor;
2209          Process   : not null access
2210            procedure (Element : in out Element_Type))
2211       is
2212          HT   : Hash_Table_Type renames Container.HT;
2213          Indx : Hash_Type;
2214
2215       begin
2216          if Position.Node = null then
2217             raise Constraint_Error with
2218               "Position cursor equals No_Element";
2219          end if;
2220
2221          if Position.Node.Element = null
2222            or else Position.Node.Next = Position.Node
2223          then
2224             raise Program_Error with "Position cursor is bad";
2225          end if;
2226
2227          if Position.Container /= Container'Unrestricted_Access then
2228             raise Program_Error with
2229               "Position cursor designates wrong set";
2230          end if;
2231
2232          if HT.Buckets = null
2233            or else HT.Buckets'Length = 0
2234            or else HT.Length = 0
2235          then
2236             raise Program_Error with "Position cursor is bad (set is empty)";
2237          end if;
2238
2239          pragma Assert
2240            (Vet (Position),
2241             "bad cursor in Update_Element_Preserving_Key");
2242
2243          Indx := HT_Ops.Index (HT, Position.Node);
2244
2245          declare
2246             E : Element_Type renames Position.Node.Element.all;
2247             K : constant Key_Type := Key (E);
2248
2249             B : Natural renames HT.Busy;
2250             L : Natural renames HT.Lock;
2251
2252          begin
2253             B := B + 1;
2254             L := L + 1;
2255
2256             begin
2257                Process (E);
2258             exception
2259                when others =>
2260                   L := L - 1;
2261                   B := B - 1;
2262                   raise;
2263             end;
2264
2265             L := L - 1;
2266             B := B - 1;
2267
2268             if Equivalent_Keys (K, Key (E)) then
2269                pragma Assert (Hash (K) = Hash (E));
2270                return;
2271             end if;
2272          end;
2273
2274          if HT.Buckets (Indx) = Position.Node then
2275             HT.Buckets (Indx) := Position.Node.Next;
2276
2277          else
2278             declare
2279                Prev : Node_Access := HT.Buckets (Indx);
2280
2281             begin
2282                while Prev.Next /= Position.Node loop
2283                   Prev := Prev.Next;
2284
2285                   if Prev = null then
2286                      raise Program_Error with
2287                        "Position cursor is bad (node not found)";
2288                   end if;
2289                end loop;
2290
2291                Prev.Next := Position.Node.Next;
2292             end;
2293          end if;
2294
2295          HT.Length := HT.Length - 1;
2296
2297          declare
2298             X : Node_Access := Position.Node;
2299
2300          begin
2301             Free (X);
2302          end;
2303
2304          raise Program_Error with "key was modified";
2305       end Update_Element_Preserving_Key;
2306
2307       -----------
2308       -- Write --
2309       -----------
2310
2311       procedure Write
2312         (Stream : not null access Root_Stream_Type'Class;
2313          Item   : Reference_Type)
2314       is
2315       begin
2316          raise Program_Error with "attempt to stream reference";
2317       end Write;
2318
2319    end Generic_Keys;
2320
2321 end Ada.Containers.Indefinite_Hashed_Sets;