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