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