gcc/ada/a-cfhama.adb

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