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