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