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