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