gcc/ada/a-cohama.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --            A D A . C O N T A I N E R S . H A S H E D _ M A P S           --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2004-2015, Free Software Foundation, Inc.         --
  10 --                                                                          --
  11 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  12 -- terms of the  GNU General Public License as published  by the Free Soft- --
  13 -- ware  Foundation;  either version 3,  or (at your option) any later ver- --
  14 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  15 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  16 -- or FITNESS FOR A PARTICULAR PURPOSE.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- This unit was originally developed by Matthew J Heaney.                  --
  28 ------------------------------------------------------------------------------
  29
  30 with Ada.Unchecked_Deallocation;
  31
  32 with Ada.Containers.Hash_Tables.Generic_Operations;
  33 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
  34
  35 with Ada.Containers.Hash_Tables.Generic_Keys;
  36 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
  37
  38 with System; use type System.Address;
  39
  40 package body Ada.Containers.Hashed_Maps is
  41
  42    pragma Annotate (CodePeer, Skip_Analysis);
  43
  44    -----------------------
  45    -- Local Subprograms --
  46    -----------------------
  47
  48    function Copy_Node
  49      (Source : Node_Access) return Node_Access;
  50    pragma Inline (Copy_Node);
  51
  52    function Equivalent_Key_Node
  53      (Key  : Key_Type;
  54       Node : Node_Access) return Boolean;
  55    pragma Inline (Equivalent_Key_Node);
  56
  57    procedure Free (X : in out Node_Access);
  58
  59    function Find_Equal_Key
  60      (R_HT   : Hash_Table_Type;
  61       L_Node : Node_Access) return Boolean;
  62
  63    function Hash_Node (Node : Node_Access) return Hash_Type;
  64    pragma Inline (Hash_Node);
  65
  66    function Next (Node : Node_Access) return Node_Access;
  67    pragma Inline (Next);
  68
  69    function Read_Node
  70      (Stream : not null access Root_Stream_Type'Class) return Node_Access;
  71    pragma Inline (Read_Node);
  72
  73    procedure Set_Next (Node : Node_Access; Next : Node_Access);
  74    pragma Inline (Set_Next);
  75
  76    function Vet (Position : Cursor) return Boolean;
  77
  78    procedure Write_Node
  79      (Stream : not null access Root_Stream_Type'Class;
  80       Node   : Node_Access);
  81    pragma Inline (Write_Node);
  82
  83    --------------------------
  84    -- Local Instantiations --
  85    --------------------------
  86
  87    package HT_Ops is new Hash_Tables.Generic_Operations
  88      (HT_Types  => HT_Types,
  89       Hash_Node => Hash_Node,
  90       Next      => Next,
  91       Set_Next  => Set_Next,
  92       Copy_Node => Copy_Node,
  93       Free      => Free);
  94
  95    package Key_Ops is new Hash_Tables.Generic_Keys
  96      (HT_Types        => HT_Types,
  97       Next            => Next,
  98       Set_Next        => Set_Next,
  99       Key_Type        => Key_Type,
 100       Hash            => Hash,
 101       Equivalent_Keys => Equivalent_Key_Node);
 102
 103    function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key);
 104
 105    procedure Read_Nodes  is new HT_Ops.Generic_Read (Read_Node);
 106    procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
 107
 108    ---------
 109    -- "=" --
 110    ---------
 111
 112    function "=" (Left, Right : Map) return Boolean is
 113    begin
 114       return Is_Equal (Left.HT, Right.HT);
 115    end "=";
 116
 117    ------------
 118    -- Adjust --
 119    ------------
 120
 121    procedure Adjust (Container : in out Map) is
 122    begin
 123       HT_Ops.Adjust (Container.HT);
 124    end Adjust;
 125
 126    procedure Adjust (Control : in out Reference_Control_Type) is
 127    begin
 128       if Control.Container /= null then
 129          declare
 130             HT : Hash_Table_Type renames Control.Container.all.HT;
 131             B  : Natural renames HT.Busy;
 132             L  : Natural renames HT.Lock;
 133          begin
 134             B := B + 1;
 135             L := L + 1;
 136          end;
 137       end if;
 138    end Adjust;
 139
 140    ------------
 141    -- Assign --
 142    ------------
 143
 144    procedure Assign (Target : in out Map; Source : Map) is
 145       procedure Insert_Item (Node : Node_Access);
 146       pragma Inline (Insert_Item);
 147
 148       procedure Insert_Items is new HT_Ops.Generic_Iteration (Insert_Item);
 149
 150       -----------------
 151       -- Insert_Item --
 152       -----------------
 153
 154       procedure Insert_Item (Node : Node_Access) is
 155       begin
 156          Target.Insert (Key => Node.Key, New_Item => Node.Element);
 157       end Insert_Item;
 158
 159    --  Start of processing for Assign
 160
 161    begin
 162       if Target'Address = Source'Address then
 163          return;
 164       end if;
 165
 166       Target.Clear;
 167
 168       if Target.Capacity < Source.Length then
 169          Target.Reserve_Capacity (Source.Length);
 170       end if;
 171
 172       Insert_Items (Source.HT);
 173    end Assign;
 174
 175    --------------
 176    -- Capacity --
 177    --------------
 178
 179    function Capacity (Container : Map) return Count_Type is
 180    begin
 181       return HT_Ops.Capacity (Container.HT);
 182    end Capacity;
 183
 184    -----------
 185    -- Clear --
 186    -----------
 187
 188    procedure Clear (Container : in out Map) is
 189    begin
 190       HT_Ops.Clear (Container.HT);
 191    end Clear;
 192
 193    ------------------------
 194    -- Constant_Reference --
 195    ------------------------
 196
 197    function Constant_Reference
 198      (Container : aliased Map;
 199       Position  : Cursor) return Constant_Reference_Type
 200    is
 201    begin
 202       if Position.Container = null then
 203          raise Constraint_Error with
 204            "Position cursor has no element";
 205       end if;
 206
 207       if Position.Container /= Container'Unrestricted_Access then
 208          raise Program_Error with
 209            "Position cursor designates wrong map";
 210       end if;
 211
 212       pragma Assert
 213         (Vet (Position),
 214          "Position cursor in Constant_Reference is bad");
 215
 216       declare
 217          HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
 218          B  : Natural renames HT.Busy;
 219          L  : Natural renames HT.Lock;
 220       begin
 221          return R : constant Constant_Reference_Type :=
 222            (Element => Position.Node.Element'Access,
 223             Control => (Controlled with Position.Container))
 224          do
 225             B := B + 1;
 226             L := L + 1;
 227          end return;
 228       end;
 229    end Constant_Reference;
 230
 231    function Constant_Reference
 232      (Container : aliased Map;
 233       Key       : Key_Type) return Constant_Reference_Type
 234    is
 235       HT   : Hash_Table_Type renames Container'Unrestricted_Access.HT;
 236       Node : constant Node_Access := Key_Ops.Find (HT, Key);
 237
 238    begin
 239       if Node = null then
 240          raise Constraint_Error with "key not in map";
 241       end if;
 242
 243       declare
 244          B  : Natural renames HT.Busy;
 245          L  : Natural renames HT.Lock;
 246       begin
 247          return R : constant Constant_Reference_Type :=
 248            (Element => Node.Element'Access,
 249             Control => (Controlled with Container'Unrestricted_Access))
 250          do
 251             B := B + 1;
 252             L := L + 1;
 253          end return;
 254       end;
 255    end Constant_Reference;
 256
 257    --------------
 258    -- Contains --
 259    --------------
 260
 261    function Contains (Container : Map; Key : Key_Type) return Boolean is
 262    begin
 263       return Find (Container, Key) /= No_Element;
 264    end Contains;
 265
 266    ----------
 267    -- Copy --
 268    ----------
 269
 270    function Copy
 271      (Source   : Map;
 272       Capacity : Count_Type := 0) return Map
 273    is
 274       C : Count_Type;
 275
 276    begin
 277       if Capacity = 0 then
 278          C := Source.Length;
 279
 280       elsif Capacity >= Source.Length then
 281          C := Capacity;
 282
 283       else
 284          raise Capacity_Error
 285            with "Requested capacity is less than Source length";
 286       end if;
 287
 288       return Target : Map do
 289          Target.Reserve_Capacity (C);
 290          Target.Assign (Source);
 291       end return;
 292    end Copy;
 293
 294    ---------------
 295    -- Copy_Node --
 296    ---------------
 297
 298    function Copy_Node
 299      (Source : Node_Access) return Node_Access
 300    is
 301       Target : constant Node_Access :=
 302         new Node_Type'(Key     => Source.Key,
 303                        Element => Source.Element,
 304                        Next    => null);
 305    begin
 306       return Target;
 307    end Copy_Node;
 308
 309    ------------
 310    -- Delete --
 311    ------------
 312
 313    procedure Delete (Container : in out Map; Key : Key_Type) is
 314       X : Node_Access;
 315
 316    begin
 317       Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
 318
 319       if X = null then
 320          raise Constraint_Error with "attempt to delete key not in map";
 321       end if;
 322
 323       Free (X);
 324    end Delete;
 325
 326    procedure Delete (Container : in out Map; Position : in out Cursor) is
 327    begin
 328       if Position.Node = null then
 329          raise Constraint_Error with
 330            "Position cursor of Delete equals No_Element";
 331       end if;
 332
 333       if Position.Container /= Container'Unrestricted_Access then
 334          raise Program_Error with
 335            "Position cursor of Delete designates wrong map";
 336       end if;
 337
 338       if Container.HT.Busy > 0 then
 339          raise Program_Error with
 340            "Delete attempted to tamper with cursors (map is busy)";
 341       end if;
 342
 343       pragma Assert (Vet (Position), "bad cursor in Delete");
 344
 345       HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
 346
 347       Free (Position.Node);
 348       Position.Container := null;
 349    end Delete;
 350
 351    -------------
 352    -- Element --
 353    -------------
 354
 355    function Element (Container : Map; Key : Key_Type) return Element_Type is
 356       HT   : Hash_Table_Type renames Container'Unrestricted_Access.HT;
 357       Node : constant Node_Access := Key_Ops.Find (HT, Key);
 358
 359    begin
 360       if Node = null then
 361          raise Constraint_Error with
 362            "no element available because key not in map";
 363       end if;
 364
 365       return Node.Element;
 366    end Element;
 367
 368    function Element (Position : Cursor) return Element_Type is
 369    begin
 370       if Position.Node = null then
 371          raise Constraint_Error with
 372            "Position cursor of function Element equals No_Element";
 373       end if;
 374
 375       pragma Assert (Vet (Position), "bad cursor in function Element");
 376
 377       return Position.Node.Element;
 378    end Element;
 379
 380    -------------------------
 381    -- Equivalent_Key_Node --
 382    -------------------------
 383
 384    function Equivalent_Key_Node
 385      (Key  : Key_Type;
 386       Node : Node_Access) return Boolean is
 387    begin
 388       return Equivalent_Keys (Key, Node.Key);
 389    end Equivalent_Key_Node;
 390
 391    ---------------------
 392    -- Equivalent_Keys --
 393    ---------------------
 394
 395    function Equivalent_Keys (Left, Right : Cursor)
 396      return Boolean is
 397    begin
 398       if Left.Node = null then
 399          raise Constraint_Error with
 400            "Left cursor of Equivalent_Keys equals No_Element";
 401       end if;
 402
 403       if Right.Node = null then
 404          raise Constraint_Error with
 405            "Right cursor of Equivalent_Keys equals No_Element";
 406       end if;
 407
 408       pragma Assert (Vet (Left), "Left cursor of Equivalent_Keys is bad");
 409       pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad");
 410
 411       return Equivalent_Keys (Left.Node.Key, Right.Node.Key);
 412    end Equivalent_Keys;
 413
 414    function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is
 415    begin
 416       if Left.Node = null then
 417          raise Constraint_Error with
 418            "Left cursor of Equivalent_Keys equals No_Element";
 419       end if;
 420
 421       pragma Assert (Vet (Left), "Left cursor in Equivalent_Keys is bad");
 422
 423       return Equivalent_Keys (Left.Node.Key, Right);
 424    end Equivalent_Keys;
 425
 426    function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is
 427    begin
 428       if Right.Node = null then
 429          raise Constraint_Error with
 430            "Right cursor of Equivalent_Keys equals No_Element";
 431       end if;
 432
 433       pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad");
 434
 435       return Equivalent_Keys (Left, Right.Node.Key);
 436    end Equivalent_Keys;
 437
 438    -------------
 439    -- Exclude --
 440    -------------
 441
 442    procedure Exclude (Container : in out Map; Key : Key_Type) is
 443       X : Node_Access;
 444    begin
 445       Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
 446       Free (X);
 447    end Exclude;
 448
 449    --------------
 450    -- Finalize --
 451    --------------
 452
 453    procedure Finalize (Container : in out Map) is
 454    begin
 455       HT_Ops.Finalize (Container.HT);
 456    end Finalize;
 457
 458    procedure Finalize (Object : in out Iterator) is
 459    begin
 460       if Object.Container /= null then
 461          declare
 462             B : Natural renames Object.Container.all.HT.Busy;
 463          begin
 464             B := B - 1;
 465          end;
 466       end if;
 467    end Finalize;
 468
 469    procedure Finalize (Control : in out Reference_Control_Type) is
 470    begin
 471       if Control.Container /= null then
 472          declare
 473             HT : Hash_Table_Type renames Control.Container.all.HT;
 474             B  : Natural renames HT.Busy;
 475             L  : Natural renames HT.Lock;
 476          begin
 477             B := B - 1;
 478             L := L - 1;
 479          end;
 480
 481          Control.Container := null;
 482       end if;
 483    end Finalize;
 484
 485    ----------
 486    -- Find --
 487    ----------
 488
 489    function Find (Container : Map; Key : Key_Type) return Cursor is
 490       HT   : Hash_Table_Type renames Container'Unrestricted_Access.HT;
 491       Node : constant Node_Access := Key_Ops.Find (HT, Key);
 492
 493    begin
 494       if Node = null then
 495          return No_Element;
 496       end if;
 497
 498       return Cursor'(Container'Unrestricted_Access, Node);
 499    end Find;
 500
 501    --------------------
 502    -- Find_Equal_Key --
 503    --------------------
 504
 505    function Find_Equal_Key
 506      (R_HT   : Hash_Table_Type;
 507       L_Node : Node_Access) return Boolean
 508    is
 509       R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key);
 510       R_Node  : Node_Access := R_HT.Buckets (R_Index);
 511
 512    begin
 513       while R_Node /= null loop
 514          if Equivalent_Keys (L_Node.Key, R_Node.Key) then
 515             return L_Node.Element = R_Node.Element;
 516          end if;
 517
 518          R_Node := R_Node.Next;
 519       end loop;
 520
 521       return False;
 522    end Find_Equal_Key;
 523
 524    -----------
 525    -- First --
 526    -----------
 527
 528    function First (Container : Map) return Cursor is
 529       Node : constant Node_Access := HT_Ops.First (Container.HT);
 530
 531    begin
 532       if Node = null then
 533          return No_Element;
 534       end if;
 535
 536       return Cursor'(Container'Unrestricted_Access, Node);
 537    end First;
 538
 539    function First (Object : Iterator) return Cursor is
 540    begin
 541       return Object.Container.First;
 542    end First;
 543
 544    ----------
 545    -- Free --
 546    ----------
 547
 548    procedure Free (X : in out Node_Access) is
 549       procedure Deallocate is
 550          new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 551    begin
 552       if X /= null then
 553          X.Next := X;     --  detect mischief (in Vet)
 554          Deallocate (X);
 555       end if;
 556    end Free;
 557
 558    ------------------------
 559    -- Get_Element_Access --
 560    ------------------------
 561
 562    function Get_Element_Access
 563      (Position : Cursor) return not null Element_Access is
 564    begin
 565       return Position.Node.Element'Access;
 566    end Get_Element_Access;
 567
 568    -----------------
 569    -- Has_Element --
 570    -----------------
 571
 572    function Has_Element (Position : Cursor) return Boolean is
 573    begin
 574       pragma Assert (Vet (Position), "bad cursor in Has_Element");
 575       return Position.Node /= null;
 576    end Has_Element;
 577
 578    ---------------
 579    -- Hash_Node --
 580    ---------------
 581
 582    function Hash_Node (Node : Node_Access) return Hash_Type is
 583    begin
 584       return Hash (Node.Key);
 585    end Hash_Node;
 586
 587    -------------
 588    -- Include --
 589    -------------
 590
 591    procedure Include
 592      (Container : in out Map;
 593       Key       : Key_Type;
 594       New_Item  : Element_Type)
 595    is
 596       Position : Cursor;
 597       Inserted : Boolean;
 598
 599    begin
 600       Insert (Container, Key, New_Item, Position, Inserted);
 601
 602       if not Inserted then
 603          if Container.HT.Lock > 0 then
 604             raise Program_Error with
 605               "Include attempted to tamper with elements (map is locked)";
 606          end if;
 607
 608          Position.Node.Key := Key;
 609          Position.Node.Element := New_Item;
 610       end if;
 611    end Include;
 612
 613    ------------
 614    -- Insert --
 615    ------------
 616
 617    procedure Insert
 618      (Container : in out Map;
 619       Key       : Key_Type;
 620       Position  : out Cursor;
 621       Inserted  : out Boolean)
 622    is
 623       function New_Node (Next : Node_Access) return Node_Access;
 624       pragma Inline (New_Node);
 625
 626       procedure Local_Insert is
 627         new Key_Ops.Generic_Conditional_Insert (New_Node);
 628
 629       --------------
 630       -- New_Node --
 631       --------------
 632
 633       function New_Node (Next : Node_Access) return Node_Access is
 634       begin
 635          return new Node_Type'(Key     => Key,
 636                                Element => <>,
 637                                Next    => Next);
 638       end New_Node;
 639
 640       HT : Hash_Table_Type renames Container.HT;
 641
 642    --  Start of processing for Insert
 643
 644    begin
 645       if HT_Ops.Capacity (HT) = 0 then
 646          HT_Ops.Reserve_Capacity (HT, 1);
 647       end if;
 648
 649       Local_Insert (HT, Key, Position.Node, Inserted);
 650
 651       if Inserted
 652         and then HT.Length > HT_Ops.Capacity (HT)
 653       then
 654          HT_Ops.Reserve_Capacity (HT, HT.Length);
 655       end if;
 656
 657       Position.Container := Container'Unrestricted_Access;
 658    end Insert;
 659
 660    procedure Insert
 661      (Container : in out Map;
 662       Key       : Key_Type;
 663       New_Item  : Element_Type;
 664       Position  : out Cursor;
 665       Inserted  : out Boolean)
 666    is
 667       function New_Node (Next : Node_Access) return Node_Access;
 668       pragma Inline (New_Node);
 669
 670       procedure Local_Insert is
 671         new Key_Ops.Generic_Conditional_Insert (New_Node);
 672
 673       --------------
 674       -- New_Node --
 675       --------------
 676
 677       function New_Node (Next : Node_Access) return Node_Access is
 678       begin
 679          return new Node_Type'(Key, New_Item, Next);
 680       end New_Node;
 681
 682       HT : Hash_Table_Type renames Container.HT;
 683
 684    --  Start of processing for Insert
 685
 686    begin
 687       if HT_Ops.Capacity (HT) = 0 then
 688          HT_Ops.Reserve_Capacity (HT, 1);
 689       end if;
 690
 691       Local_Insert (HT, Key, Position.Node, Inserted);
 692
 693       if Inserted
 694         and then HT.Length > HT_Ops.Capacity (HT)
 695       then
 696          HT_Ops.Reserve_Capacity (HT, HT.Length);
 697       end if;
 698
 699       Position.Container := Container'Unrestricted_Access;
 700    end Insert;
 701
 702    procedure Insert
 703      (Container : in out Map;
 704       Key       : Key_Type;
 705       New_Item  : Element_Type)
 706    is
 707       Position : Cursor;
 708       pragma Unreferenced (Position);
 709
 710       Inserted : Boolean;
 711
 712    begin
 713       Insert (Container, Key, New_Item, Position, Inserted);
 714
 715       if not Inserted then
 716          raise Constraint_Error with
 717            "attempt to insert key already in map";
 718       end if;
 719    end Insert;
 720
 721    --------------
 722    -- Is_Empty --
 723    --------------
 724
 725    function Is_Empty (Container : Map) return Boolean is
 726    begin
 727       return Container.HT.Length = 0;
 728    end Is_Empty;
 729
 730    -------------
 731    -- Iterate --
 732    -------------
 733
 734    procedure Iterate
 735      (Container : Map;
 736       Process   : not null access procedure (Position : Cursor))
 737    is
 738       procedure Process_Node (Node : Node_Access);
 739       pragma Inline (Process_Node);
 740
 741       procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node);
 742
 743       ------------------
 744       -- Process_Node --
 745       ------------------
 746
 747       procedure Process_Node (Node : Node_Access) is
 748       begin
 749          Process (Cursor'(Container'Unrestricted_Access, Node));
 750       end Process_Node;
 751
 752       B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
 753
 754    --  Start of processing for Iterate
 755
 756    begin
 757       B := B + 1;
 758
 759       begin
 760          Local_Iterate (Container.HT);
 761       exception
 762          when others =>
 763             B := B - 1;
 764             raise;
 765       end;
 766
 767       B := B - 1;
 768    end Iterate;
 769
 770    function Iterate
 771      (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class
 772    is
 773       B  : Natural renames Container'Unrestricted_Access.all.HT.Busy;
 774    begin
 775       return It : constant Iterator :=
 776         (Limited_Controlled with Container => Container'Unrestricted_Access)
 777       do
 778          B := B + 1;
 779       end return;
 780    end Iterate;
 781
 782    ---------
 783    -- Key --
 784    ---------
 785
 786    function Key (Position : Cursor) return Key_Type is
 787    begin
 788       if Position.Node = null then
 789          raise Constraint_Error with
 790            "Position cursor of function Key equals No_Element";
 791       end if;
 792
 793       pragma Assert (Vet (Position), "bad cursor in function Key");
 794
 795       return Position.Node.Key;
 796    end Key;
 797
 798    ------------
 799    -- Length --
 800    ------------
 801
 802    function Length (Container : Map) return Count_Type is
 803    begin
 804       return Container.HT.Length;
 805    end Length;
 806
 807    ----------
 808    -- Move --
 809    ----------
 810
 811    procedure Move
 812      (Target : in out Map;
 813       Source : in out Map)
 814    is
 815    begin
 816       HT_Ops.Move (Target => Target.HT, Source => Source.HT);
 817    end Move;
 818
 819    ----------
 820    -- Next --
 821    ----------
 822
 823    function Next (Node : Node_Access) return Node_Access is
 824    begin
 825       return Node.Next;
 826    end Next;
 827
 828    function Next (Position : Cursor) return Cursor is
 829    begin
 830       if Position.Node = null then
 831          return No_Element;
 832       end if;
 833
 834       pragma Assert (Vet (Position), "bad cursor in function Next");
 835
 836       declare
 837          HT   : Hash_Table_Type renames Position.Container.HT;
 838          Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
 839
 840       begin
 841          if Node = null then
 842             return No_Element;
 843          end if;
 844
 845          return Cursor'(Position.Container, Node);
 846       end;
 847    end Next;
 848
 849    procedure Next (Position : in out Cursor) is
 850    begin
 851       Position := Next (Position);
 852    end Next;
 853
 854    function Next
 855      (Object   : Iterator;
 856       Position : Cursor) return Cursor
 857    is
 858    begin
 859       if Position.Container = null then
 860          return No_Element;
 861       end if;
 862
 863       if Position.Container /= Object.Container then
 864          raise Program_Error with
 865            "Position cursor of Next designates wrong map";
 866       end if;
 867
 868       return Next (Position);
 869    end Next;
 870
 871    ----------------------
 872    -- Pseudo_Reference --
 873    ----------------------
 874
 875    function Pseudo_Reference
 876      (Container : aliased Map'Class) return Reference_Control_Type
 877    is
 878       C : constant Map_Access := Container'Unrestricted_Access;
 879       B : Natural renames C.HT.Busy;
 880       L : Natural renames C.HT.Lock;
 881    begin
 882       return R : constant Reference_Control_Type :=
 883         (Controlled with C)
 884       do
 885          B := B + 1;
 886          L := L + 1;
 887       end return;
 888    end Pseudo_Reference;
 889
 890    -------------------
 891    -- Query_Element --
 892    -------------------
 893
 894    procedure Query_Element
 895      (Position : Cursor;
 896       Process  : not null access
 897                    procedure (Key : Key_Type; Element : Element_Type))
 898    is
 899    begin
 900       if Position.Node = null then
 901          raise Constraint_Error with
 902            "Position cursor of Query_Element equals No_Element";
 903       end if;
 904
 905       pragma Assert (Vet (Position), "bad cursor in Query_Element");
 906
 907       declare
 908          M  : Map renames Position.Container.all;
 909          HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
 910
 911          B : Natural renames HT.Busy;
 912          L : Natural renames HT.Lock;
 913
 914       begin
 915          B := B + 1;
 916          L := L + 1;
 917
 918          declare
 919             K : Key_Type renames Position.Node.Key;
 920             E : Element_Type renames Position.Node.Element;
 921          begin
 922             Process (K, E);
 923          exception
 924             when others =>
 925                L := L - 1;
 926                B := B - 1;
 927                raise;
 928          end;
 929
 930          L := L - 1;
 931          B := B - 1;
 932       end;
 933    end Query_Element;
 934
 935    ----------
 936    -- Read --
 937    ----------
 938
 939    procedure Read
 940      (Stream    : not null access Root_Stream_Type'Class;
 941       Container : out Map)
 942    is
 943    begin
 944       Read_Nodes (Stream, Container.HT);
 945    end Read;
 946
 947    procedure Read
 948      (Stream : not null access Root_Stream_Type'Class;
 949       Item   : out Cursor)
 950    is
 951    begin
 952       raise Program_Error with "attempt to stream map cursor";
 953    end Read;
 954
 955    procedure Read
 956      (Stream : not null access Root_Stream_Type'Class;
 957       Item   : out Reference_Type)
 958    is
 959    begin
 960       raise Program_Error with "attempt to stream reference";
 961    end Read;
 962
 963    procedure Read
 964      (Stream : not null access Root_Stream_Type'Class;
 965       Item   : out Constant_Reference_Type)
 966    is
 967    begin
 968       raise Program_Error with "attempt to stream reference";
 969    end Read;
 970
 971    ---------------
 972    -- Reference --
 973    ---------------
 974
 975    function Reference
 976      (Container : aliased in out Map;
 977       Position  : Cursor) return Reference_Type
 978    is
 979    begin
 980       if Position.Container = null then
 981          raise Constraint_Error with
 982            "Position cursor has no element";
 983       end if;
 984
 985       if Position.Container /= Container'Unrestricted_Access then
 986          raise Program_Error with
 987            "Position cursor designates wrong map";
 988       end if;
 989
 990       pragma Assert
 991         (Vet (Position),
 992          "Position cursor in function Reference is bad");
 993
 994       declare
 995          HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
 996          B  : Natural renames HT.Busy;
 997          L  : Natural renames HT.Lock;
 998       begin
 999          return R : constant Reference_Type :=
1000            (Element => Position.Node.Element'Access,
1001             Control => (Controlled with Position.Container))
1002          do
1003             B := B + 1;
1004             L := L + 1;
1005          end return;
1006       end;
1007    end Reference;
1008
1009    function Reference
1010      (Container : aliased in out Map;
1011       Key       : Key_Type) return Reference_Type
1012    is
1013       HT   : Hash_Table_Type renames Container.HT;
1014       Node : constant Node_Access := Key_Ops.Find (HT, Key);
1015
1016    begin
1017       if Node = null then
1018          raise Constraint_Error with "key not in map";
1019       end if;
1020
1021       declare
1022          B  : Natural renames HT.Busy;
1023          L  : Natural renames HT.Lock;
1024       begin
1025          return R : constant Reference_Type :=
1026            (Element => Node.Element'Access,
1027             Control => (Controlled with Container'Unrestricted_Access))
1028          do
1029             B := B + 1;
1030             L := L + 1;
1031          end return;
1032       end;
1033    end Reference;
1034
1035    ---------------
1036    -- Read_Node --
1037    ---------------
1038
1039    function Read_Node
1040      (Stream : not null access Root_Stream_Type'Class) return Node_Access
1041    is
1042       Node : Node_Access := new Node_Type;
1043
1044    begin
1045       Key_Type'Read (Stream, Node.Key);
1046       Element_Type'Read (Stream, Node.Element);
1047       return Node;
1048
1049    exception
1050       when others =>
1051          Free (Node);
1052          raise;
1053    end Read_Node;
1054
1055    -------------
1056    -- Replace --
1057    -------------
1058
1059    procedure Replace
1060      (Container : in out Map;
1061       Key       : Key_Type;
1062       New_Item  : Element_Type)
1063    is
1064       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
1065
1066    begin
1067       if Node = null then
1068          raise Constraint_Error with
1069            "attempt to replace key not in map";
1070       end if;
1071
1072       if Container.HT.Lock > 0 then
1073          raise Program_Error with
1074            "Replace attempted to tamper with elements (map is locked)";
1075       end if;
1076
1077       Node.Key := Key;
1078       Node.Element := New_Item;
1079    end Replace;
1080
1081    ---------------------
1082    -- Replace_Element --
1083    ---------------------
1084
1085    procedure Replace_Element
1086      (Container : in out Map;
1087       Position  : Cursor;
1088       New_Item  : Element_Type)
1089    is
1090    begin
1091       if Position.Node = null then
1092          raise Constraint_Error with
1093            "Position cursor of Replace_Element equals No_Element";
1094       end if;
1095
1096       if Position.Container /= Container'Unrestricted_Access then
1097          raise Program_Error with
1098            "Position cursor of Replace_Element designates wrong map";
1099       end if;
1100
1101       if Position.Container.HT.Lock > 0 then
1102          raise Program_Error with
1103            "Replace_Element attempted to tamper with elements (map is locked)";
1104       end if;
1105
1106       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1107
1108       Position.Node.Element := New_Item;
1109    end Replace_Element;
1110
1111    ----------------------
1112    -- Reserve_Capacity --
1113    ----------------------
1114
1115    procedure Reserve_Capacity
1116      (Container : in out Map;
1117       Capacity  : Count_Type)
1118    is
1119    begin
1120       HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1121    end Reserve_Capacity;
1122
1123    --------------
1124    -- Set_Next --
1125    --------------
1126
1127    procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1128    begin
1129       Node.Next := Next;
1130    end Set_Next;
1131
1132    --------------------
1133    -- Update_Element --
1134    --------------------
1135
1136    procedure Update_Element
1137      (Container : in out Map;
1138       Position  : Cursor;
1139       Process   : not null access procedure (Key     : Key_Type;
1140                                              Element : in out Element_Type))
1141    is
1142    begin
1143       if Position.Node = null then
1144          raise Constraint_Error with
1145            "Position cursor of Update_Element equals No_Element";
1146       end if;
1147
1148       if Position.Container /= Container'Unrestricted_Access then
1149          raise Program_Error with
1150            "Position cursor of Update_Element designates wrong map";
1151       end if;
1152
1153       pragma Assert (Vet (Position), "bad cursor in Update_Element");
1154
1155       declare
1156          HT : Hash_Table_Type renames Container.HT;
1157          B  : Natural renames HT.Busy;
1158          L  : Natural renames HT.Lock;
1159
1160       begin
1161          B := B + 1;
1162          L := L + 1;
1163
1164          declare
1165             K : Key_Type renames Position.Node.Key;
1166             E : Element_Type renames Position.Node.Element;
1167          begin
1168             Process (K, E);
1169          exception
1170             when others =>
1171                L := L - 1;
1172                B := B - 1;
1173                raise;
1174          end;
1175
1176          L := L - 1;
1177          B := B - 1;
1178       end;
1179    end Update_Element;
1180
1181    ---------
1182    -- Vet --
1183    ---------
1184
1185    function Vet (Position : Cursor) return Boolean is
1186    begin
1187       if Position.Node = null then
1188          return Position.Container = null;
1189       end if;
1190
1191       if Position.Container = null then
1192          return False;
1193       end if;
1194
1195       if Position.Node.Next = Position.Node then
1196          return False;
1197       end if;
1198
1199       declare
1200          HT : Hash_Table_Type renames Position.Container.HT;
1201          X  : Node_Access;
1202
1203       begin
1204          if HT.Length = 0 then
1205             return False;
1206          end if;
1207
1208          if HT.Buckets = null
1209            or else HT.Buckets'Length = 0
1210          then
1211             return False;
1212          end if;
1213
1214          X := HT.Buckets (Key_Ops.Checked_Index (HT, Position.Node.Key));
1215
1216          for J in 1 .. HT.Length loop
1217             if X = Position.Node then
1218                return True;
1219             end if;
1220
1221             if X = null then
1222                return False;
1223             end if;
1224
1225             if X = X.Next then  --  to prevent unnecessary looping
1226                return False;
1227             end if;
1228
1229             X := X.Next;
1230          end loop;
1231
1232          return False;
1233       end;
1234    end Vet;
1235
1236    -----------
1237    -- Write --
1238    -----------
1239
1240    procedure Write
1241      (Stream    : not null access Root_Stream_Type'Class;
1242       Container : Map)
1243    is
1244    begin
1245       Write_Nodes (Stream, Container.HT);
1246    end Write;
1247
1248    procedure Write
1249      (Stream : not null access Root_Stream_Type'Class;
1250       Item   : Cursor)
1251    is
1252    begin
1253       raise Program_Error with "attempt to stream map cursor";
1254    end Write;
1255
1256    procedure Write
1257      (Stream : not null access Root_Stream_Type'Class;
1258       Item   : Reference_Type)
1259    is
1260    begin
1261       raise Program_Error with "attempt to stream reference";
1262    end Write;
1263
1264    procedure Write
1265      (Stream : not null access Root_Stream_Type'Class;
1266       Item   : Constant_Reference_Type)
1267    is
1268    begin
1269       raise Program_Error with "attempt to stream reference";
1270    end Write;
1271
1272    ----------------
1273    -- Write_Node --
1274    ----------------
1275
1276    procedure Write_Node
1277      (Stream : not null access Root_Stream_Type'Class;
1278       Node   : Node_Access)
1279    is
1280    begin
1281       Key_Type'Write (Stream, Node.Key);
1282       Element_Type'Write (Stream, Node.Element);
1283    end Write_Node;
1284
1285 end Ada.Containers.Hashed_Maps;