gcc/ada/a-cihase.adb

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