gcc/ada/a-cihase.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                  ADA.CONTAINERS.INDEFINITE_HASHED_SETS                   --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --             Copyright (C) 2004 Free Software Foundation, Inc.            --
  10 --                                                                          --
  11 -- This specification is derived from the Ada Reference Manual for use with --
  12 -- GNAT. The copyright notice above, and the license provisions that follow --
  13 -- apply solely to the  contents of the part following the private keyword. --
  14 --                                                                          --
  15 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  16 -- terms of the  GNU General Public License as published  by the Free Soft- --
  17 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  18 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  19 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  20 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  21 -- for  more details.  You should have  received  a copy of the GNU General --
  22 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  23 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  24 -- MA 02111-1307, USA.                                                      --
  25 --                                                                          --
  26 -- As a special exception,  if other files  instantiate  generics from this --
  27 -- unit, or you link  this unit with other files  to produce an executable, --
  28 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  29 -- covered  by the  GNU  General  Public  License.  This exception does not --
  30 -- however invalidate  any other reasons why  the executable file  might be --
  31 -- covered by the  GNU Public License.                                      --
  32 --                                                                          --
  33 -- This unit has originally being developed by Matthew J Heaney.            --
  34 ------------------------------------------------------------------------------
  35
  36 with Ada.Unchecked_Deallocation;
  37
  38 with Ada.Containers.Hash_Tables.Generic_Operations;
  39 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
  40
  41 with Ada.Containers.Hash_Tables.Generic_Keys;
  42 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
  43
  44 with System;  use type System.Address;
  45
  46 with Ada.Containers.Prime_Numbers;
  47
  48 with Ada.Finalization;  use Ada.Finalization;
  49
  50 package body Ada.Containers.Indefinite_Hashed_Sets is
  51
  52    type Element_Access is access Element_Type;
  53
  54    type Node_Type is
  55       limited record
  56          Element : Element_Access;
  57          Next    : Node_Access;
  58       end record;
  59
  60    function Hash_Node
  61      (Node : Node_Access) return Hash_Type;
  62    pragma Inline (Hash_Node);
  63
  64    function Hash_Node
  65      (Node : Node_Access) return Hash_Type is
  66    begin
  67       return Hash (Node.Element.all);
  68    end Hash_Node;
  69
  70    function Next
  71      (Node : Node_Access) return Node_Access;
  72    pragma Inline (Next);
  73
  74    function Next
  75      (Node : Node_Access) return Node_Access is
  76    begin
  77       return Node.Next;
  78    end Next;
  79
  80    procedure Set_Next
  81      (Node : Node_Access;
  82       Next : Node_Access);
  83    pragma Inline (Set_Next);
  84
  85    procedure Set_Next
  86      (Node : Node_Access;
  87       Next : Node_Access) is
  88    begin
  89       Node.Next := Next;
  90    end Set_Next;
  91
  92    function Equivalent_Keys
  93      (Key  : Element_Type;
  94       Node : Node_Access) return Boolean;
  95    pragma Inline (Equivalent_Keys);
  96
  97    function Equivalent_Keys
  98      (Key  : Element_Type;
  99       Node : Node_Access) return Boolean is
 100    begin
 101       return Equivalent_Keys (Key, Node.Element.all);
 102    end Equivalent_Keys;
 103
 104    function Copy_Node
 105      (Source : Node_Access) return Node_Access;
 106    pragma Inline (Copy_Node);
 107
 108    function Copy_Node
 109      (Source : Node_Access) return Node_Access is
 110
 111       Target : constant Node_Access :=
 112         new Node_Type'(Element => Source.Element,
 113                        Next    => null);
 114    begin
 115       return Target;
 116    end Copy_Node;
 117
 118
 119    procedure Free_Element is
 120       new Ada.Unchecked_Deallocation (Element_Type, Element_Access);
 121
 122    procedure Free (X : in out Node_Access);
 123
 124    procedure Free (X : in out Node_Access) is
 125       procedure Deallocate is
 126          new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 127    begin
 128       if X /= null then
 129          Free_Element (X.Element);
 130          Deallocate (X);
 131       end if;
 132    end Free;
 133
 134    package HT_Ops is
 135       new Hash_Tables.Generic_Operations
 136        (HT_Types          => HT_Types,
 137         Hash_Table_Type   => Set,
 138         Null_Node         => null,
 139         Hash_Node         => Hash_Node,
 140         Next              => Next,
 141         Set_Next          => Set_Next,
 142         Copy_Node         => Copy_Node,
 143         Free              => Free);
 144
 145    package Element_Keys is
 146       new Hash_Tables.Generic_Keys
 147        (HT_Types  => HT_Types,
 148         HT_Type   => Set,
 149         Null_Node => null,
 150         Next      => Next,
 151         Set_Next  => Set_Next,
 152         Key_Type  => Element_Type,
 153         Hash      => Hash,
 154         Equivalent_Keys => Equivalent_Keys);
 155
 156
 157    procedure Adjust (Container : in out Set) renames HT_Ops.Adjust;
 158
 159    procedure Finalize (Container : in out Set) renames HT_Ops.Finalize;
 160
 161
 162    function Find_Equal_Key
 163      (R_Set  : Set;
 164       L_Node : Node_Access) return Boolean;
 165
 166    function Find_Equal_Key
 167      (R_Set  : Set;
 168       L_Node : Node_Access) return Boolean is
 169
 170       R_Index : constant Hash_Type :=
 171         Element_Keys.Index (R_Set, L_Node.Element.all);
 172
 173       R_Node  : Node_Access := R_Set.Buckets (R_Index);
 174
 175    begin
 176
 177       loop
 178
 179          if R_Node = null then
 180             return False;
 181          end if;
 182
 183          if L_Node.Element.all = R_Node.Element.all then
 184             return True;
 185          end if;
 186
 187          R_Node := Next (R_Node);
 188
 189       end loop;
 190
 191    end Find_Equal_Key;
 192
 193    function Is_Equal is
 194       new HT_Ops.Generic_Equal (Find_Equal_Key);
 195
 196    function "=" (Left, Right : Set) return Boolean renames Is_Equal;
 197
 198
 199    function Length (Container : Set) return Count_Type is
 200    begin
 201       return Container.Length;
 202    end Length;
 203
 204
 205    function Is_Empty (Container : Set) return Boolean is
 206    begin
 207       return Container.Length = 0;
 208    end Is_Empty;
 209
 210
 211    procedure Clear (Container : in out Set) renames HT_Ops.Clear;
 212
 213
 214    function Element (Position : Cursor) return Element_Type is
 215    begin
 216       return Position.Node.Element.all;
 217    end Element;
 218
 219
 220    procedure Query_Element
 221      (Position : in Cursor;
 222       Process  : not null access procedure (Element : in Element_Type)) is
 223    begin
 224       Process (Position.Node.Element.all);
 225    end Query_Element;
 226
 227
 228 --  TODO:
 229 --     procedure Replace_Element (Container : in out Set;
 230 --                                Position  : in     Node_Access;
 231 --                                By        : in     Element_Type);
 232
 233 --     procedure Replace_Element (Container : in out Set;
 234 --                                Position  : in     Node_Access;
 235 --                                By        : in     Element_Type) is
 236
 237 --        Node : Node_Access := Position;
 238
 239 --     begin
 240
 241 --        if Equivalent_Keys (Node.Element.all, By) then
 242
 243 --           declare
 244 --              X : Element_Access := Node.Element;
 245 --           begin
 246 --              Node.Element := new Element_Type'(By);
 247 --              --
 248 --              --  NOTE: If there's an exception here, then just
 249 --              --  let it propagate.  We haven't modified the
 250 --              --  state of the container, so there's nothing else
 251 --              --  we need to do.
 252
 253 --              Free_Element (X);
 254 --           end;
 255
 256 --           return;
 257
 258 --        end if;
 259
 260 --        HT_Ops.Delete_Node_Sans_Free (Container, Node);
 261
 262 --        begin
 263 --           Free_Element (Node.Element);
 264 --        exception
 265 --           when others =>
 266 --              Node.Element := null;  --  don't attempt to dealloc X.E again
 267 --              Free (Node);
 268 --              raise;
 269 --        end;
 270
 271 --        begin
 272 --           Node.Element := new Element_Type'(By);
 273 --        exception
 274 --           when others =>
 275 --              Free (Node);
 276 --              raise;
 277 --        end;
 278
 279 --        declare
 280 --           function New_Node (Next : Node_Access) return Node_Access;
 281 --           pragma Inline (New_Node);
 282
 283 --           function New_Node (Next : Node_Access) return Node_Access is
 284 --           begin
 285 --              Node.Next := Next;
 286 --              return Node;
 287 --           end New_Node;
 288
 289 --           procedure Insert is
 290 --              new Element_Keys.Generic_Conditional_Insert (New_Node);
 291
 292 --           Result  : Node_Access;
 293 --           Success : Boolean;
 294 --        begin
 295 --           Insert
 296 --             (HT      => Container,
 297 --              Key     => Node.Element.all,
 298 --              Node    => Result,
 299 --              Success => Success);
 300
 301 --           if not Success then
 302 --              Free (Node);
 303 --              raise Program_Error;
 304 --           end if;
 305
 306 --           pragma Assert (Result = Node);
 307 --        end;
 308
 309 --     end Replace_Element;
 310
 311
 312 --     procedure Replace_Element (Container : in out Set;
 313 --                                Position  : in     Cursor;
 314 --                                By        : in     Element_Type) is
 315 --     begin
 316
 317 --        if Position.Container = null then
 318 --           raise Constraint_Error;
 319 --        end if;
 320
 321 --        if Position.Container /= Set_Access'(Container'Unchecked_Access) then
 322 --           raise Program_Error;
 323 --        end if;
 324
 325 --        Replace_Element (Container, Position.Node, By);
 326
 327 --     end Replace_Element;
 328
 329
 330    procedure Move (Target : in out Set;
 331                    Source : in out Set) renames HT_Ops.Move;
 332
 333
 334    procedure Insert (Container : in out Set;
 335                      New_Item  : in     Element_Type;
 336                      Position  :    out Cursor;
 337                      Inserted  :    out Boolean) is
 338
 339       function New_Node (Next : Node_Access) return Node_Access;
 340       pragma Inline (New_Node);
 341
 342       function New_Node (Next : Node_Access) return Node_Access is
 343          Element : Element_Access := new Element_Type'(New_Item);
 344       begin
 345          return new Node_Type'(Element, Next);
 346       exception
 347          when others =>
 348             Free_Element (Element);
 349             raise;
 350       end New_Node;
 351
 352       procedure Insert is
 353         new Element_Keys.Generic_Conditional_Insert (New_Node);
 354
 355    begin
 356
 357       HT_Ops.Ensure_Capacity (Container, Container.Length + 1);
 358       Insert (Container, New_Item, Position.Node, Inserted);
 359       Position.Container := Container'Unchecked_Access;
 360
 361    end Insert;
 362
 363
 364    procedure Insert (Container : in out Set;
 365                      New_Item  : in     Element_Type) is
 366
 367       Position : Cursor;
 368       Inserted : Boolean;
 369
 370    begin
 371
 372       Insert (Container, New_Item, Position, Inserted);
 373
 374       if not Inserted then
 375          raise Constraint_Error;
 376       end if;
 377
 378    end Insert;
 379
 380
 381    procedure Replace (Container : in out Set;
 382                       New_Item  : in     Element_Type) is
 383
 384       Node : constant Node_Access :=
 385         Element_Keys.Find (Container, New_Item);
 386
 387       X : Element_Access;
 388
 389    begin
 390
 391       if Node = null then
 392          raise Constraint_Error;
 393       end if;
 394
 395       X := Node.Element;
 396
 397       Node.Element := new Element_Type'(New_Item);
 398
 399       Free_Element (X);
 400
 401    end Replace;
 402
 403
 404    procedure Include (Container : in out Set;
 405                       New_Item  : in     Element_Type) is
 406
 407       Position : Cursor;
 408       Inserted : Boolean;
 409
 410       X : Element_Access;
 411
 412    begin
 413
 414       Insert (Container, New_Item, Position, Inserted);
 415
 416       if not Inserted then
 417
 418          X := Position.Node.Element;
 419
 420          Position.Node.Element := new Element_Type'(New_Item);
 421
 422          Free_Element (X);
 423
 424       end if;
 425
 426    end Include;
 427
 428
 429    procedure Delete (Container : in out Set;
 430                      Item      : in     Element_Type) is
 431
 432       X : Node_Access;
 433
 434    begin
 435
 436       Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
 437
 438       if X = null then
 439          raise Constraint_Error;
 440       end if;
 441
 442       Free (X);
 443
 444    end Delete;
 445
 446
 447    procedure Exclude (Container : in out Set;
 448                       Item      : in     Element_Type) is
 449
 450       X : Node_Access;
 451
 452    begin
 453
 454       Element_Keys.Delete_Key_Sans_Free (Container, Item, X);
 455       Free (X);
 456
 457    end Exclude;
 458
 459
 460    procedure Delete (Container : in out Set;
 461                      Position  : in out Cursor) is
 462    begin
 463
 464       if Position = No_Element then
 465          return;
 466       end if;
 467
 468       if Position.Container /= Set_Access'(Container'Unchecked_Access) then
 469          raise Program_Error;
 470       end if;
 471
 472       HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
 473       Free (Position.Node);
 474
 475       Position.Container := null;
 476
 477    end Delete;
 478
 479
 480
 481    procedure Union (Target : in out Set;
 482                     Source : in     Set) is
 483
 484       procedure Process (Src_Node : in Node_Access);
 485
 486       procedure Process (Src_Node : in Node_Access) is
 487
 488          Src : Element_Type renames Src_Node.Element.all;
 489
 490          function New_Node (Next : Node_Access) return Node_Access;
 491          pragma Inline (New_Node);
 492
 493          function New_Node (Next : Node_Access) return Node_Access is
 494             Tgt : Element_Access := new Element_Type'(Src);
 495          begin
 496             return new Node_Type'(Tgt, Next);
 497          exception
 498             when others =>
 499                Free_Element (Tgt);
 500                raise;
 501          end New_Node;
 502
 503          procedure Insert is
 504             new Element_Keys.Generic_Conditional_Insert (New_Node);
 505
 506          Tgt_Node : Node_Access;
 507          Success  : Boolean;
 508
 509       begin
 510
 511          Insert (Target, Src, Tgt_Node, Success);
 512
 513       end Process;
 514
 515       procedure Iterate is
 516          new HT_Ops.Generic_Iteration (Process);
 517
 518    begin
 519
 520       if Target'Address = Source'Address then
 521          return;
 522       end if;
 523
 524       HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length);
 525
 526       Iterate (Source);
 527
 528    end Union;
 529
 530
 531
 532    function Union (Left, Right : Set) return Set is
 533
 534       Buckets : HT_Types.Buckets_Access;
 535       Length  : Count_Type;
 536
 537    begin
 538
 539       if Left'Address = Right'Address then
 540          return Left;
 541       end if;
 542
 543       if Right.Length = 0 then
 544          return Left;
 545       end if;
 546
 547       if Left.Length = 0 then
 548          return Right;
 549       end if;
 550
 551       declare
 552          Size : constant Hash_Type :=
 553            Prime_Numbers.To_Prime (Left.Length + Right.Length);
 554       begin
 555          Buckets := new Buckets_Type (0 .. Size - 1);
 556       end;
 557
 558       declare
 559          procedure Process (L_Node : Node_Access);
 560
 561          procedure Process (L_Node : Node_Access) is
 562             I : constant Hash_Type :=
 563               Hash (L_Node.Element.all) mod Buckets'Length;
 564          begin
 565             Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I));
 566          end Process;
 567
 568          procedure Iterate is
 569             new HT_Ops.Generic_Iteration (Process);
 570       begin
 571          Iterate (Left);
 572       exception
 573          when others =>
 574             HT_Ops.Free_Hash_Table (Buckets);
 575             raise;
 576       end;
 577
 578       Length := Left.Length;
 579
 580       declare
 581          procedure Process (Src_Node : Node_Access);
 582
 583          procedure Process (Src_Node : Node_Access) is
 584
 585             Src : Element_Type renames Src_Node.Element.all;
 586
 587             I : constant Hash_Type :=
 588               Hash (Src) mod Buckets'Length;
 589
 590             Tgt_Node : Node_Access := Buckets (I);
 591
 592          begin
 593
 594             while Tgt_Node /= null loop
 595
 596                if Equivalent_Keys (Src, Tgt_Node.Element.all) then
 597                   return;
 598                end if;
 599
 600                Tgt_Node := Next (Tgt_Node);
 601
 602             end loop;
 603
 604             declare
 605                Tgt : Element_Access := new Element_Type'(Src);
 606             begin
 607                Buckets (I) := new Node_Type'(Tgt, Buckets (I));
 608             exception
 609                when others =>
 610                   Free_Element (Tgt);
 611                   raise;
 612             end;
 613
 614             Length := Length + 1;
 615
 616          end Process;
 617
 618          procedure Iterate is
 619             new HT_Ops.Generic_Iteration (Process);
 620       begin
 621          Iterate (Right);
 622       exception
 623          when others =>
 624             HT_Ops.Free_Hash_Table (Buckets);
 625             raise;
 626       end;
 627
 628       return (Controlled with Buckets, Length);
 629
 630    end Union;
 631
 632
 633    function Is_In
 634      (HT  : Set;
 635       Key : Node_Access) return Boolean;
 636    pragma Inline (Is_In);
 637
 638    function Is_In
 639      (HT  : Set;
 640       Key : Node_Access) return Boolean is
 641    begin
 642       return Element_Keys.Find (HT, Key.Element.all) /= null;
 643    end Is_In;
 644
 645
 646    procedure Intersection (Target : in out Set;
 647                            Source : in     Set) is
 648
 649       Tgt_Node : Node_Access;
 650
 651    begin
 652
 653       if Target'Address = Source'Address then
 654          return;
 655       end if;
 656
 657       if Source.Length = 0 then
 658          Clear (Target);
 659          return;
 660       end if;
 661
 662       --  TODO: optimize this to use an explicit
 663       --  loop instead of an active iterator
 664       --  (similar to how a passive iterator is
 665       --  implemented).
 666       --
 667       --  Another possibility is to test which
 668       --  set is smaller, and iterate over the
 669       --  smaller set.
 670
 671       Tgt_Node := HT_Ops.First (Target);
 672
 673       while Tgt_Node /= null loop
 674
 675          if Is_In (Source, Tgt_Node) then
 676
 677             Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
 678
 679          else
 680
 681             declare
 682                X : Node_Access := Tgt_Node;
 683             begin
 684                Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
 685                HT_Ops.Delete_Node_Sans_Free (Target, X);
 686                Free (X);
 687             end;
 688
 689          end if;
 690
 691       end loop;
 692
 693    end Intersection;
 694
 695
 696    function Intersection (Left, Right : Set) return Set is
 697
 698       Buckets : HT_Types.Buckets_Access;
 699       Length  : Count_Type;
 700
 701    begin
 702
 703       if Left'Address = Right'Address then
 704          return Left;
 705       end if;
 706
 707       Length := Count_Type'Min (Left.Length, Right.Length);
 708
 709       if Length = 0 then
 710          return Empty_Set;
 711       end if;
 712
 713       declare
 714          Size : constant Hash_Type := Prime_Numbers.To_Prime (Length);
 715       begin
 716          Buckets := new Buckets_Type (0 .. Size - 1);
 717       end;
 718
 719       Length := 0;
 720
 721       declare
 722          procedure Process (L_Node : Node_Access);
 723
 724          procedure Process (L_Node : Node_Access) is
 725          begin
 726             if Is_In (Right, L_Node) then
 727
 728                declare
 729                   I : constant Hash_Type :=
 730                     Hash (L_Node.Element.all) mod Buckets'Length;
 731                begin
 732                   Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I));
 733                end;
 734
 735                Length := Length + 1;
 736
 737             end if;
 738          end Process;
 739
 740          procedure Iterate is
 741             new HT_Ops.Generic_Iteration (Process);
 742       begin
 743          Iterate (Left);
 744       exception
 745          when others =>
 746             HT_Ops.Free_Hash_Table (Buckets);
 747             raise;
 748       end;
 749
 750       return (Controlled with Buckets, Length);
 751
 752    end Intersection;
 753
 754
 755    procedure Difference (Target : in out Set;
 756                          Source : in     Set) is
 757
 758
 759       Tgt_Node : Node_Access;
 760
 761    begin
 762
 763       if Target'Address = Source'Address then
 764          Clear (Target);
 765          return;
 766       end if;
 767
 768       if Source.Length = 0 then
 769          return;
 770       end if;
 771
 772       --  TODO: As I noted above, this can be
 773       --  written in terms of a loop instead as
 774       --  active-iterator style, sort of like a
 775       --  passive iterator.
 776
 777       Tgt_Node := HT_Ops.First (Target);
 778
 779       while Tgt_Node /= null loop
 780
 781          if Is_In (Source, Tgt_Node) then
 782
 783             declare
 784                X : Node_Access := Tgt_Node;
 785             begin
 786                Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
 787                HT_Ops.Delete_Node_Sans_Free (Target, X);
 788                Free (X);
 789             end;
 790
 791          else
 792
 793             Tgt_Node := HT_Ops.Next (Target, Tgt_Node);
 794
 795          end if;
 796
 797       end loop;
 798
 799    end Difference;
 800
 801
 802
 803    function Difference (Left, Right : Set) return Set is
 804
 805       Buckets : HT_Types.Buckets_Access;
 806       Length  : Count_Type;
 807
 808    begin
 809
 810       if Left'Address = Right'Address then
 811          return Empty_Set;
 812       end if;
 813
 814       if Left.Length = 0 then
 815          return Empty_Set;
 816       end if;
 817
 818       if Right.Length = 0 then
 819          return Left;
 820       end if;
 821
 822       declare
 823          Size : constant Hash_Type := Prime_Numbers.To_Prime (Left.Length);
 824       begin
 825          Buckets := new Buckets_Type (0 .. Size - 1);
 826       end;
 827
 828       Length := 0;
 829
 830       declare
 831          procedure Process (L_Node : Node_Access);
 832
 833          procedure Process (L_Node : Node_Access) is
 834          begin
 835             if not Is_In (Right, L_Node) then
 836
 837                declare
 838                   I : constant Hash_Type :=
 839                     Hash (L_Node.Element.all) mod Buckets'Length;
 840                begin
 841                   Buckets (I) := new Node_Type'(L_Node.Element, Buckets (I));
 842                end;
 843
 844                Length := Length + 1;
 845
 846             end if;
 847          end Process;
 848
 849          procedure Iterate is
 850             new HT_Ops.Generic_Iteration (Process);
 851       begin
 852          Iterate (Left);
 853       exception
 854          when others =>
 855             HT_Ops.Free_Hash_Table (Buckets);
 856             raise;
 857       end;
 858
 859       return (Controlled with Buckets, Length);
 860
 861    end Difference;
 862
 863
 864
 865    procedure Symmetric_Difference (Target : in out Set;
 866                                    Source : in     Set) is
 867    begin
 868
 869       if Target'Address = Source'Address then
 870          Clear (Target);
 871          return;
 872       end if;
 873
 874       HT_Ops.Ensure_Capacity (Target, Target.Length + Source.Length);
 875
 876       if Target.Length = 0 then
 877
 878          declare
 879             procedure Process (Src_Node : Node_Access);
 880
 881             procedure Process (Src_Node : Node_Access) is
 882                E : Element_Type renames Src_Node.Element.all;
 883                B : Buckets_Type renames Target.Buckets.all;
 884                I : constant Hash_Type := Hash (E) mod B'Length;
 885                N : Count_Type renames Target.Length;
 886             begin
 887                declare
 888                   X : Element_Access := new Element_Type'(E);
 889                begin
 890                   B (I) := new Node_Type'(X, B (I));
 891                exception
 892                   when others =>
 893                      Free_Element (X);
 894                      raise;
 895                end;
 896
 897                N := N + 1;
 898             end Process;
 899
 900             procedure Iterate is
 901                new HT_Ops.Generic_Iteration (Process);
 902          begin
 903             Iterate (Source);
 904          end;
 905
 906       else
 907
 908          declare
 909             procedure Process (Src_Node : Node_Access);
 910
 911             procedure Process (Src_Node : Node_Access) is
 912                E : Element_Type renames Src_Node.Element.all;
 913                B : Buckets_Type renames Target.Buckets.all;
 914                I : constant Hash_Type := Hash (E) mod B'Length;
 915                N : Count_Type renames Target.Length;
 916             begin
 917                if B (I) = null then
 918
 919                   declare
 920                      X : Element_Access := new Element_Type'(E);
 921                   begin
 922                      B (I) := new Node_Type'(X, null);
 923                   exception
 924                      when others =>
 925                         Free_Element (X);
 926                         raise;
 927                   end;
 928
 929                   N := N + 1;
 930
 931                elsif Equivalent_Keys (E, B (I).Element.all) then
 932
 933                   declare
 934                      X : Node_Access := B (I);
 935                   begin
 936                      B (I) := B (I).Next;
 937                      N := N - 1;
 938                      Free (X);
 939                   end;
 940
 941                else
 942
 943                   declare
 944                      Prev : Node_Access := B (I);
 945                      Curr : Node_Access := Prev.Next;
 946                   begin
 947                      while Curr /= null loop
 948                         if Equivalent_Keys (E, Curr.Element.all) then
 949                            Prev.Next := Curr.Next;
 950                            N := N - 1;
 951                            Free (Curr);
 952                            return;
 953                         end if;
 954
 955                         Prev := Curr;
 956                         Curr := Prev.Next;
 957                      end loop;
 958
 959                      declare
 960                         X : Element_Access := new Element_Type'(E);
 961                      begin
 962                         B (I) := new Node_Type'(X, B (I));
 963                      exception
 964                         when others =>
 965                            Free_Element (X);
 966                            raise;
 967                      end;
 968
 969                      N := N + 1;
 970                   end;
 971
 972                end if;
 973             end Process;
 974
 975             procedure Iterate is
 976                new HT_Ops.Generic_Iteration (Process);
 977          begin
 978             Iterate (Source);
 979          end;
 980
 981       end if;
 982
 983    end Symmetric_Difference;
 984
 985
 986    function Symmetric_Difference (Left, Right : Set) return Set is
 987
 988       Buckets : HT_Types.Buckets_Access;
 989       Length  : Count_Type;
 990
 991    begin
 992
 993       if Left'Address = Right'Address then
 994          return Empty_Set;
 995       end if;
 996
 997       if Right.Length = 0 then
 998          return Left;
 999       end if;
1000
1001       if Left.Length = 0 then
1002          return Right;
1003       end if;
1004
1005       declare
1006          Size : constant Hash_Type :=
1007            Prime_Numbers.To_Prime (Left.Length + Right.Length);
1008       begin
1009          Buckets := new Buckets_Type (0 .. Size - 1);
1010       end;
1011
1012       Length := 0;
1013
1014       declare
1015          procedure Process (L_Node : Node_Access);
1016
1017          procedure Process (L_Node : Node_Access) is
1018          begin
1019             if not Is_In (Right, L_Node) then
1020                declare
1021                   E : Element_Type renames L_Node.Element.all;
1022                   I : constant Hash_Type := Hash (E) mod Buckets'Length;
1023                begin
1024
1025                   declare
1026                      X : Element_Access := new Element_Type'(E);
1027                   begin
1028                      Buckets (I) := new Node_Type'(X, Buckets (I));
1029                   exception
1030                      when others =>
1031                         Free_Element (X);
1032                         raise;
1033                   end;
1034
1035                   Length := Length + 1;
1036                end;
1037             end if;
1038          end Process;
1039
1040          procedure Iterate is
1041             new HT_Ops.Generic_Iteration (Process);
1042       begin
1043          Iterate (Left);
1044       exception
1045          when others =>
1046             HT_Ops.Free_Hash_Table (Buckets);
1047             raise;
1048       end;
1049
1050       declare
1051          procedure Process (R_Node : Node_Access);
1052
1053          procedure Process (R_Node : Node_Access) is
1054          begin
1055             if not Is_In (Left, R_Node) then
1056                declare
1057                   E : Element_Type renames R_Node.Element.all;
1058                   I : constant Hash_Type := Hash (E) mod Buckets'Length;
1059                begin
1060
1061                   declare
1062                      X : Element_Access := new Element_Type'(E);
1063                   begin
1064                      Buckets (I) := new Node_Type'(X, Buckets (I));
1065                   exception
1066                      when others =>
1067                         Free_Element (X);
1068                         raise;
1069                   end;
1070
1071                   Length := Length + 1;
1072
1073                end;
1074             end if;
1075          end Process;
1076
1077          procedure Iterate is
1078             new HT_Ops.Generic_Iteration (Process);
1079       begin
1080          Iterate (Right);
1081       exception
1082          when others =>
1083             HT_Ops.Free_Hash_Table (Buckets);
1084             raise;
1085       end;
1086
1087       return (Controlled with Buckets, Length);
1088
1089    end Symmetric_Difference;
1090
1091
1092    function Is_Subset (Subset : Set;
1093                        Of_Set : Set) return Boolean is
1094
1095       Subset_Node : Node_Access;
1096
1097    begin
1098
1099       if Subset'Address = Of_Set'Address then
1100          return True;
1101       end if;
1102
1103       if Subset.Length > Of_Set.Length then
1104          return False;
1105       end if;
1106
1107       --  TODO: rewrite this to loop in the
1108       --  style of a passive iterator.
1109
1110       Subset_Node := HT_Ops.First (Subset);
1111
1112       while Subset_Node /= null loop
1113          if not Is_In (Of_Set, Subset_Node) then
1114             return False;
1115          end if;
1116
1117          Subset_Node := HT_Ops.Next (Subset, Subset_Node);
1118       end loop;
1119
1120       return True;
1121
1122    end Is_Subset;
1123
1124
1125    function Overlap (Left, Right : Set) return Boolean is
1126
1127       Left_Node : Node_Access;
1128
1129    begin
1130
1131       if Right.Length = 0 then
1132          return False;
1133       end if;
1134
1135       if Left'Address = Right'Address then
1136          return True;
1137       end if;
1138
1139       Left_Node := HT_Ops.First (Left);
1140
1141       while Left_Node /= null loop
1142          if Is_In (Right, Left_Node) then
1143             return True;
1144          end if;
1145
1146          Left_Node := HT_Ops.Next (Left, Left_Node);
1147       end loop;
1148
1149       return False;
1150
1151    end Overlap;
1152
1153
1154    function Find (Container : Set;
1155                   Item      : Element_Type) return Cursor is
1156
1157       Node : constant Node_Access := Element_Keys.Find (Container, Item);
1158
1159    begin
1160
1161       if Node = null then
1162          return No_Element;
1163       end if;
1164
1165       return Cursor'(Container'Unchecked_Access, Node);
1166
1167    end Find;
1168
1169
1170    function Contains (Container : Set;
1171                       Item      : Element_Type) return Boolean is
1172    begin
1173       return Find (Container, Item) /= No_Element;
1174    end Contains;
1175
1176
1177
1178    function First (Container : Set) return Cursor is
1179       Node : constant Node_Access := HT_Ops.First (Container);
1180    begin
1181       if Node = null then
1182          return No_Element;
1183       end if;
1184
1185       return Cursor'(Container'Unchecked_Access, Node);
1186    end First;
1187
1188
1189 --     function First_Element (Container : Set) return Element_Type is
1190 --        Node : constant Node_Access := HT_Ops.First (Container);
1191 --     begin
1192 --        return Node.Element;
1193 --     end First_Element;
1194
1195
1196    function Next (Position : Cursor) return Cursor is
1197    begin
1198       if Position.Container = null
1199         or else Position.Node = null
1200       then
1201          return No_Element;
1202       end if;
1203
1204       declare
1205          S : Set renames Position.Container.all;
1206          Node : constant Node_Access := HT_Ops.Next (S, Position.Node);
1207       begin
1208          if Node = null then
1209             return No_Element;
1210          end if;
1211
1212          return Cursor'(Position.Container, Node);
1213       end;
1214    end Next;
1215
1216
1217    procedure Next (Position : in out Cursor) is
1218    begin
1219       Position := Next (Position);
1220    end Next;
1221
1222
1223    function Has_Element (Position : Cursor) return Boolean is
1224    begin
1225       if Position.Container = null then
1226          return False;
1227       end if;
1228
1229       if Position.Node = null then
1230          return False;
1231       end if;
1232
1233       return True;
1234    end Has_Element;
1235
1236
1237    function Equivalent_Keys (Left, Right : Cursor)
1238      return Boolean is
1239    begin
1240       return Equivalent_Keys (Left.Node.Element.all, Right.Node.Element.all);
1241    end Equivalent_Keys;
1242
1243
1244    function Equivalent_Keys (Left  : Cursor;
1245                              Right : Element_Type)
1246     return Boolean is
1247    begin
1248       return Equivalent_Keys (Left.Node.Element.all, Right);
1249    end Equivalent_Keys;
1250
1251
1252    function Equivalent_Keys (Left  : Element_Type;
1253                              Right : Cursor)
1254     return Boolean is
1255    begin
1256       return Equivalent_Keys (Left, Right.Node.Element.all);
1257    end Equivalent_Keys;
1258
1259
1260    procedure Iterate
1261      (Container : in Set;
1262       Process   : not null access procedure (Position : in Cursor)) is
1263
1264       procedure Process_Node (Node : in Node_Access);
1265       pragma Inline (Process_Node);
1266
1267       procedure Process_Node (Node : in Node_Access) is
1268       begin
1269          Process (Cursor'(Container'Unchecked_Access, Node));
1270       end Process_Node;
1271
1272       procedure Iterate is
1273          new HT_Ops.Generic_Iteration (Process_Node);
1274    begin
1275       Iterate (Container);
1276    end Iterate;
1277
1278
1279    function Capacity (Container : Set) return Count_Type
1280      renames HT_Ops.Capacity;
1281
1282    procedure Reserve_Capacity
1283      (Container : in out Set;
1284       Capacity  : in     Count_Type)
1285      renames HT_Ops.Ensure_Capacity;
1286
1287
1288    procedure Write_Node
1289      (Stream : access Root_Stream_Type'Class;
1290       Node   : in     Node_Access);
1291    pragma Inline (Write_Node);
1292
1293    procedure Write_Node
1294      (Stream : access Root_Stream_Type'Class;
1295       Node   : in     Node_Access) is
1296    begin
1297       Element_Type'Output (Stream, Node.Element.all);
1298    end Write_Node;
1299
1300    procedure Write_Nodes is
1301       new HT_Ops.Generic_Write (Write_Node);
1302
1303    procedure Write
1304      (Stream    : access Root_Stream_Type'Class;
1305       Container : in     Set) renames Write_Nodes;
1306
1307
1308    function Read_Node (Stream : access Root_Stream_Type'Class)
1309      return Node_Access;
1310    pragma Inline (Read_Node);
1311
1312    function Read_Node (Stream : access Root_Stream_Type'Class)
1313      return Node_Access is
1314
1315       X : Element_Access := new Element_Type'(Element_Type'Input (Stream));
1316    begin
1317       return new Node_Type'(X, null);
1318    exception
1319       when others =>
1320          Free_Element (X);
1321          raise;
1322    end Read_Node;
1323
1324    procedure Read_Nodes is
1325       new HT_Ops.Generic_Read (Read_Node);
1326
1327    procedure Read
1328      (Stream    : access Root_Stream_Type'Class;
1329       Container :    out Set) renames Read_Nodes;
1330
1331
1332    package body Generic_Keys is
1333
1334       function Equivalent_Keys (Left  : Cursor;
1335                                 Right : Key_Type)
1336         return Boolean is
1337       begin
1338          return Equivalent_Keys (Right, Left.Node.Element.all);
1339       end Equivalent_Keys;
1340
1341       function Equivalent_Keys (Left  : Key_Type;
1342                                 Right : Cursor)
1343         return Boolean is
1344       begin
1345          return Equivalent_Keys (Left, Right.Node.Element.all);
1346       end Equivalent_Keys;
1347
1348       function Equivalent_Keys
1349         (Key  : Key_Type;
1350          Node : Node_Access) return Boolean;
1351       pragma Inline (Equivalent_Keys);
1352
1353       function Equivalent_Keys
1354         (Key  : Key_Type;
1355          Node : Node_Access) return Boolean is
1356       begin
1357          return Equivalent_Keys (Key, Node.Element.all);
1358       end Equivalent_Keys;
1359
1360       package Key_Keys is
1361          new Hash_Tables.Generic_Keys
1362           (HT_Types  => HT_Types,
1363            HT_Type   => Set,
1364            Null_Node => null,
1365            Next      => Next,
1366            Set_Next  => Set_Next,
1367            Key_Type  => Key_Type,
1368            Hash      => Hash,
1369            Equivalent_Keys => Equivalent_Keys);
1370
1371
1372       function Find (Container : Set;
1373                      Key       : Key_Type)
1374          return Cursor is
1375
1376          Node : constant Node_Access :=
1377            Key_Keys.Find (Container, Key);
1378
1379       begin
1380
1381          if Node = null then
1382             return No_Element;
1383          end if;
1384
1385          return Cursor'(Container'Unchecked_Access, Node);
1386
1387       end Find;
1388
1389
1390       function Contains (Container : Set;
1391                          Key       : Key_Type) return Boolean is
1392       begin
1393          return Find (Container, Key) /= No_Element;
1394       end Contains;
1395
1396
1397       function Element (Container : Set;
1398                         Key       : Key_Type)
1399         return Element_Type is
1400
1401          Node : constant Node_Access := Key_Keys.Find (Container, Key);
1402       begin
1403          return Node.Element.all;
1404       end Element;
1405
1406
1407       function Key (Position : Cursor) return Key_Type is
1408       begin
1409          return Key (Position.Node.Element.all);
1410       end Key;
1411
1412
1413 --  TODO:
1414 --        procedure Replace (Container : in out Set;
1415 --                           Key       : in     Key_Type;
1416 --                           New_Item  : in     Element_Type) is
1417
1418 --           Node : constant Node_Access :=
1419 --             Key_Keys.Find (Container, Key);
1420
1421 --        begin
1422
1423 --           if Node = null then
1424 --              raise Constraint_Error;
1425 --           end if;
1426
1427 --           Replace_Element (Container, Node, New_Item);
1428
1429 --        end Replace;
1430
1431
1432       procedure Delete (Container : in out Set;
1433                         Key       : in     Key_Type) is
1434
1435          X : Node_Access;
1436
1437       begin
1438
1439          Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
1440
1441          if X = null then
1442             raise Constraint_Error;
1443          end if;
1444
1445          Free (X);
1446
1447       end Delete;
1448
1449
1450       procedure Exclude (Container : in out Set;
1451                          Key       : in     Key_Type) is
1452
1453          X : Node_Access;
1454
1455       begin
1456
1457          Key_Keys.Delete_Key_Sans_Free (Container, Key, X);
1458          Free (X);
1459
1460       end Exclude;
1461
1462
1463       procedure Checked_Update_Element
1464         (Container : in out Set;
1465          Position  : in     Cursor;
1466          Process   : not null access
1467            procedure (Element : in out Element_Type)) is
1468
1469       begin
1470
1471          if Position.Container = null then
1472             raise Constraint_Error;
1473          end if;
1474
1475          if Position.Container /= Set_Access'(Container'Unchecked_Access) then
1476             raise Program_Error;
1477          end if;
1478
1479          declare
1480             Old_Key : Key_Type renames Key (Position.Node.Element.all);
1481          begin
1482             Process (Position.Node.Element.all);
1483
1484             if Equivalent_Keys (Old_Key, Position.Node.Element.all) then
1485                return;
1486             end if;
1487          end;
1488
1489          declare
1490             function New_Node (Next : Node_Access) return Node_Access;
1491             pragma Inline (New_Node);
1492
1493             function New_Node (Next : Node_Access) return Node_Access is
1494             begin
1495                Position.Node.Next := Next;
1496                return Position.Node;
1497             end New_Node;
1498
1499             procedure Insert is
1500                new Key_Keys.Generic_Conditional_Insert (New_Node);
1501
1502             Result  : Node_Access;
1503             Success : Boolean;
1504          begin
1505             HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
1506
1507             Insert
1508               (HT      => Container,
1509                Key     => Key (Position.Node.Element.all),
1510                Node    => Result,
1511                Success => Success);
1512
1513             if not Success then
1514                declare
1515                   X : Node_Access := Position.Node;
1516                begin
1517                   Free (X);
1518                end;
1519
1520                raise Program_Error;
1521             end if;
1522
1523             pragma Assert (Result = Position.Node);
1524          end;
1525
1526       end Checked_Update_Element;
1527
1528    end Generic_Keys;
1529
1530 end Ada.Containers.Indefinite_Hashed_Sets;
1531