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 => (Controlled with Container'Unrestricted_Access))
 262          do
 263             B := B + 1;
 264             L := L + 1;
 265          end return;
 266       end;
 267    end Constant_Reference;
 268
 269    --------------
 270    -- Contains --
 271    --------------
 272
 273    function Contains (Container : Map; Key : Key_Type) return Boolean is
 274    begin
 275       return Find (Container, Key) /= No_Element;
 276    end Contains;
 277
 278    ----------
 279    -- Copy --
 280    ----------
 281
 282    function Copy
 283      (Source   : Map;
 284       Capacity : Count_Type := 0) return Map
 285    is
 286       C : Count_Type;
 287
 288    begin
 289       if Capacity = 0 then
 290          C := Source.Length;
 291
 292       elsif Capacity >= Source.Length then
 293          C := Capacity;
 294
 295       else
 296          raise Capacity_Error
 297            with "Requested capacity is less than Source length";
 298       end if;
 299
 300       return Target : Map do
 301          Target.Reserve_Capacity (C);
 302          Target.Assign (Source);
 303       end return;
 304    end Copy;
 305
 306    ---------------
 307    -- Copy_Node --
 308    ---------------
 309
 310    function Copy_Node
 311      (Source : Node_Access) return Node_Access
 312    is
 313       Target : constant Node_Access :=
 314         new Node_Type'(Key     => Source.Key,
 315                        Element => Source.Element,
 316                        Next    => null);
 317    begin
 318       return Target;
 319    end Copy_Node;
 320
 321    ------------
 322    -- Delete --
 323    ------------
 324
 325    procedure Delete (Container : in out Map; Key : Key_Type) is
 326       X : Node_Access;
 327
 328    begin
 329       Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
 330
 331       if X = null then
 332          raise Constraint_Error with "attempt to delete key not in map";
 333       end if;
 334
 335       Free (X);
 336    end Delete;
 337
 338    procedure Delete (Container : in out Map; Position : in out Cursor) is
 339    begin
 340       if Position.Node = null then
 341          raise Constraint_Error with
 342            "Position cursor of Delete equals No_Element";
 343       end if;
 344
 345       if Position.Container /= Container'Unrestricted_Access then
 346          raise Program_Error with
 347            "Position cursor of Delete designates wrong map";
 348       end if;
 349
 350       if Container.HT.Busy > 0 then
 351          raise Program_Error with
 352            "Delete attempted to tamper with cursors (map is busy)";
 353       end if;
 354
 355       pragma Assert (Vet (Position), "bad cursor in Delete");
 356
 357       HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
 358
 359       Free (Position.Node);
 360       Position.Container := null;
 361    end Delete;
 362
 363    -------------
 364    -- Element --
 365    -------------
 366
 367    function Element (Container : Map; Key : Key_Type) return Element_Type is
 368       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
 369
 370    begin
 371       if Node = null then
 372          raise Constraint_Error with
 373            "no element available because key not in map";
 374       end if;
 375
 376       return Node.Element;
 377    end Element;
 378
 379    function Element (Position : Cursor) return Element_Type is
 380    begin
 381       if Position.Node = null then
 382          raise Constraint_Error with
 383            "Position cursor of function Element equals No_Element";
 384       end if;
 385
 386       pragma Assert (Vet (Position), "bad cursor in function Element");
 387
 388       return Position.Node.Element;
 389    end Element;
 390
 391    -------------------------
 392    -- Equivalent_Key_Node --
 393    -------------------------
 394
 395    function Equivalent_Key_Node
 396      (Key  : Key_Type;
 397       Node : Node_Access) return Boolean is
 398    begin
 399       return Equivalent_Keys (Key, Node.Key);
 400    end Equivalent_Key_Node;
 401
 402    ---------------------
 403    -- Equivalent_Keys --
 404    ---------------------
 405
 406    function Equivalent_Keys (Left, Right : Cursor)
 407      return Boolean is
 408    begin
 409       if Left.Node = null then
 410          raise Constraint_Error with
 411            "Left cursor of Equivalent_Keys equals No_Element";
 412       end if;
 413
 414       if Right.Node = null then
 415          raise Constraint_Error with
 416            "Right cursor of Equivalent_Keys equals No_Element";
 417       end if;
 418
 419       pragma Assert (Vet (Left), "Left cursor of Equivalent_Keys is bad");
 420       pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad");
 421
 422       return Equivalent_Keys (Left.Node.Key, Right.Node.Key);
 423    end Equivalent_Keys;
 424
 425    function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is
 426    begin
 427       if Left.Node = null then
 428          raise Constraint_Error with
 429            "Left cursor of Equivalent_Keys equals No_Element";
 430       end if;
 431
 432       pragma Assert (Vet (Left), "Left cursor in Equivalent_Keys is bad");
 433
 434       return Equivalent_Keys (Left.Node.Key, Right);
 435    end Equivalent_Keys;
 436
 437    function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is
 438    begin
 439       if Right.Node = null then
 440          raise Constraint_Error with
 441            "Right cursor of Equivalent_Keys equals No_Element";
 442       end if;
 443
 444       pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad");
 445
 446       return Equivalent_Keys (Left, Right.Node.Key);
 447    end Equivalent_Keys;
 448
 449    -------------
 450    -- Exclude --
 451    -------------
 452
 453    procedure Exclude (Container : in out Map; Key : Key_Type) is
 454       X : Node_Access;
 455    begin
 456       Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
 457       Free (X);
 458    end Exclude;
 459
 460    --------------
 461    -- Finalize --
 462    --------------
 463
 464    procedure Finalize (Container : in out Map) is
 465    begin
 466       HT_Ops.Finalize (Container.HT);
 467    end Finalize;
 468
 469    procedure Finalize (Object : in out Iterator) is
 470    begin
 471       if Object.Container /= null then
 472          declare
 473             B : Natural renames Object.Container.all.HT.Busy;
 474          begin
 475             B := B - 1;
 476          end;
 477       end if;
 478    end Finalize;
 479
 480    procedure Finalize (Control : in out Reference_Control_Type) is
 481    begin
 482       if Control.Container /= null then
 483          declare
 484             HT : Hash_Table_Type renames Control.Container.all.HT;
 485             B  : Natural renames HT.Busy;
 486             L  : Natural renames HT.Lock;
 487          begin
 488             B := B - 1;
 489             L := L - 1;
 490          end;
 491
 492          Control.Container := null;
 493       end if;
 494    end Finalize;
 495
 496    ----------
 497    -- Find --
 498    ----------
 499
 500    function Find (Container : Map; Key : Key_Type) return Cursor is
 501       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
 502
 503    begin
 504       if Node = null then
 505          return No_Element;
 506       end if;
 507
 508       return Cursor'(Container'Unrestricted_Access, Node);
 509    end Find;
 510
 511    --------------------
 512    -- Find_Equal_Key --
 513    --------------------
 514
 515    function Find_Equal_Key
 516      (R_HT   : Hash_Table_Type;
 517       L_Node : Node_Access) return Boolean
 518    is
 519       R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key);
 520       R_Node  : Node_Access := R_HT.Buckets (R_Index);
 521
 522    begin
 523       while R_Node /= null loop
 524          if Equivalent_Keys (L_Node.Key, R_Node.Key) then
 525             return L_Node.Element = R_Node.Element;
 526          end if;
 527
 528          R_Node := R_Node.Next;
 529       end loop;
 530
 531       return False;
 532    end Find_Equal_Key;
 533
 534    -----------
 535    -- First --
 536    -----------
 537
 538    function First (Container : Map) return Cursor is
 539       Node : constant Node_Access := HT_Ops.First (Container.HT);
 540
 541    begin
 542       if Node = null then
 543          return No_Element;
 544       end if;
 545
 546       return Cursor'(Container'Unrestricted_Access, Node);
 547    end First;
 548
 549    function First (Object : Iterator) return Cursor is
 550    begin
 551       return Object.Container.First;
 552    end First;
 553
 554    ----------
 555    -- Free --
 556    ----------
 557
 558    procedure Free (X : in out Node_Access) is
 559       procedure Deallocate is
 560          new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 561    begin
 562       if X /= null then
 563          X.Next := X;     --  detect mischief (in Vet)
 564          Deallocate (X);
 565       end if;
 566    end Free;
 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    -- Query_Element --
 873    -------------------
 874
 875    procedure Query_Element
 876      (Position : Cursor;
 877       Process  : not null access
 878                    procedure (Key : Key_Type; Element : Element_Type))
 879    is
 880    begin
 881       if Position.Node = null then
 882          raise Constraint_Error with
 883            "Position cursor of Query_Element equals No_Element";
 884       end if;
 885
 886       pragma Assert (Vet (Position), "bad cursor in Query_Element");
 887
 888       declare
 889          M  : Map renames Position.Container.all;
 890          HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
 891
 892          B : Natural renames HT.Busy;
 893          L : Natural renames HT.Lock;
 894
 895       begin
 896          B := B + 1;
 897          L := L + 1;
 898
 899          declare
 900             K : Key_Type renames Position.Node.Key;
 901             E : Element_Type renames Position.Node.Element;
 902
 903          begin
 904             Process (K, E);
 905          exception
 906             when others =>
 907                L := L - 1;
 908                B := B - 1;
 909                raise;
 910          end;
 911
 912          L := L - 1;
 913          B := B - 1;
 914       end;
 915    end Query_Element;
 916
 917    ----------
 918    -- Read --
 919    ----------
 920
 921    procedure Read
 922      (Stream    : not null access Root_Stream_Type'Class;
 923       Container : out Map)
 924    is
 925    begin
 926       Read_Nodes (Stream, Container.HT);
 927    end Read;
 928
 929    procedure Read
 930      (Stream : not null access Root_Stream_Type'Class;
 931       Item   : out Cursor)
 932    is
 933    begin
 934       raise Program_Error with "attempt to stream map cursor";
 935    end Read;
 936
 937    procedure Read
 938      (Stream : not null access Root_Stream_Type'Class;
 939       Item   : out Reference_Type)
 940    is
 941    begin
 942       raise Program_Error with "attempt to stream reference";
 943    end Read;
 944
 945    procedure Read
 946      (Stream : not null access Root_Stream_Type'Class;
 947       Item   : out Constant_Reference_Type)
 948    is
 949    begin
 950       raise Program_Error with "attempt to stream reference";
 951    end Read;
 952
 953    ---------------
 954    -- Reference --
 955    ---------------
 956
 957    function Reference
 958      (Container : aliased in out Map;
 959       Position  : Cursor) return Reference_Type
 960    is
 961    begin
 962       if Position.Container = null then
 963          raise Constraint_Error with
 964            "Position cursor has no element";
 965       end if;
 966
 967       if Position.Container /= Container'Unrestricted_Access then
 968          raise Program_Error with
 969            "Position cursor designates wrong map";
 970       end if;
 971
 972       pragma Assert
 973         (Vet (Position),
 974          "Position cursor in function Reference is bad");
 975
 976       declare
 977          HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
 978          B  : Natural renames HT.Busy;
 979          L  : Natural renames HT.Lock;
 980       begin
 981          return R : constant Reference_Type :=
 982            (Element => Position.Node.Element'Access,
 983             Control => (Controlled with Position.Container))
 984          do
 985             B := B + 1;
 986             L := L + 1;
 987          end return;
 988       end;
 989    end Reference;
 990
 991    function Reference
 992      (Container : aliased in out Map;
 993       Key       : Key_Type) return Reference_Type
 994    is
 995       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
 996
 997    begin
 998       if Node = null then
 999          raise Constraint_Error with "key not in map";
1000       end if;
1001
1002       declare
1003          HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
1004          B  : Natural renames HT.Busy;
1005          L  : Natural renames HT.Lock;
1006       begin
1007          return R : constant Reference_Type :=
1008            (Element => Node.Element'Access,
1009             Control => (Controlled with Container'Unrestricted_Access))
1010          do
1011             B := B + 1;
1012             L := L + 1;
1013          end return;
1014       end;
1015    end Reference;
1016
1017    ---------------
1018    -- Read_Node --
1019    ---------------
1020
1021    function Read_Node
1022      (Stream : not null access Root_Stream_Type'Class) return Node_Access
1023    is
1024       Node : Node_Access := new Node_Type;
1025
1026    begin
1027       Key_Type'Read (Stream, Node.Key);
1028       Element_Type'Read (Stream, Node.Element);
1029       return Node;
1030
1031    exception
1032       when others =>
1033          Free (Node);
1034          raise;
1035    end Read_Node;
1036
1037    -------------
1038    -- Replace --
1039    -------------
1040
1041    procedure Replace
1042      (Container : in out Map;
1043       Key       : Key_Type;
1044       New_Item  : Element_Type)
1045    is
1046       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
1047
1048    begin
1049       if Node = null then
1050          raise Constraint_Error with
1051            "attempt to replace key not in map";
1052       end if;
1053
1054       if Container.HT.Lock > 0 then
1055          raise Program_Error with
1056            "Replace attempted to tamper with elements (map is locked)";
1057       end if;
1058
1059       Node.Key := Key;
1060       Node.Element := New_Item;
1061    end Replace;
1062
1063    ---------------------
1064    -- Replace_Element --
1065    ---------------------
1066
1067    procedure Replace_Element
1068      (Container : in out Map;
1069       Position  : Cursor;
1070       New_Item  : Element_Type)
1071    is
1072    begin
1073       if Position.Node = null then
1074          raise Constraint_Error with
1075            "Position cursor of Replace_Element equals No_Element";
1076       end if;
1077
1078       if Position.Container /= Container'Unrestricted_Access then
1079          raise Program_Error with
1080            "Position cursor of Replace_Element designates wrong map";
1081       end if;
1082
1083       if Position.Container.HT.Lock > 0 then
1084          raise Program_Error with
1085            "Replace_Element attempted to tamper with elements (map is locked)";
1086       end if;
1087
1088       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1089
1090       Position.Node.Element := New_Item;
1091    end Replace_Element;
1092
1093    ----------------------
1094    -- Reserve_Capacity --
1095    ----------------------
1096
1097    procedure Reserve_Capacity
1098      (Container : in out Map;
1099       Capacity  : Count_Type)
1100    is
1101    begin
1102       HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1103    end Reserve_Capacity;
1104
1105    --------------
1106    -- Set_Next --
1107    --------------
1108
1109    procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1110    begin
1111       Node.Next := Next;
1112    end Set_Next;
1113
1114    --------------------
1115    -- Update_Element --
1116    --------------------
1117
1118    procedure Update_Element
1119      (Container : in out Map;
1120       Position  : Cursor;
1121       Process   : not null access procedure (Key     : Key_Type;
1122                                              Element : in out Element_Type))
1123    is
1124    begin
1125       if Position.Node = null then
1126          raise Constraint_Error with
1127            "Position cursor of Update_Element equals No_Element";
1128       end if;
1129
1130       if Position.Container /= Container'Unrestricted_Access then
1131          raise Program_Error with
1132            "Position cursor of Update_Element designates wrong map";
1133       end if;
1134
1135       pragma Assert (Vet (Position), "bad cursor in Update_Element");
1136
1137       declare
1138          HT : Hash_Table_Type renames Container.HT;
1139          B  : Natural renames HT.Busy;
1140          L  : Natural renames HT.Lock;
1141
1142       begin
1143          B := B + 1;
1144          L := L + 1;
1145
1146          declare
1147             K : Key_Type renames Position.Node.Key;
1148             E : Element_Type renames Position.Node.Element;
1149
1150          begin
1151             Process (K, E);
1152
1153          exception
1154             when others =>
1155                L := L - 1;
1156                B := B - 1;
1157                raise;
1158          end;
1159
1160          L := L - 1;
1161          B := B - 1;
1162       end;
1163    end Update_Element;
1164
1165    ---------
1166    -- Vet --
1167    ---------
1168
1169    function Vet (Position : Cursor) return Boolean is
1170    begin
1171       if Position.Node = null then
1172          return Position.Container = null;
1173       end if;
1174
1175       if Position.Container = null then
1176          return False;
1177       end if;
1178
1179       if Position.Node.Next = Position.Node then
1180          return False;
1181       end if;
1182
1183       declare
1184          HT : Hash_Table_Type renames Position.Container.HT;
1185          X  : Node_Access;
1186
1187       begin
1188          if HT.Length = 0 then
1189             return False;
1190          end if;
1191
1192          if HT.Buckets = null
1193            or else HT.Buckets'Length = 0
1194          then
1195             return False;
1196          end if;
1197
1198          X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key));
1199
1200          for J in 1 .. HT.Length loop
1201             if X = Position.Node then
1202                return True;
1203             end if;
1204
1205             if X = null then
1206                return False;
1207             end if;
1208
1209             if X = X.Next then  --  to prevent unnecessary looping
1210                return False;
1211             end if;
1212
1213             X := X.Next;
1214          end loop;
1215
1216          return False;
1217       end;
1218    end Vet;
1219
1220    -----------
1221    -- Write --
1222    -----------
1223
1224    procedure Write
1225      (Stream    : not null access Root_Stream_Type'Class;
1226       Container : Map)
1227    is
1228    begin
1229       Write_Nodes (Stream, Container.HT);
1230    end Write;
1231
1232    procedure Write
1233      (Stream : not null access Root_Stream_Type'Class;
1234       Item   : Cursor)
1235    is
1236    begin
1237       raise Program_Error with "attempt to stream map cursor";
1238    end Write;
1239
1240    procedure Write
1241      (Stream : not null access Root_Stream_Type'Class;
1242       Item   : Reference_Type)
1243    is
1244    begin
1245       raise Program_Error with "attempt to stream reference";
1246    end Write;
1247
1248    procedure Write
1249      (Stream : not null access Root_Stream_Type'Class;
1250       Item   : Constant_Reference_Type)
1251    is
1252    begin
1253       raise Program_Error with "attempt to stream reference";
1254    end Write;
1255
1256    ----------------
1257    -- Write_Node --
1258    ----------------
1259
1260    procedure Write_Node
1261      (Stream : not null access Root_Stream_Type'Class;
1262       Node   : Node_Access)
1263    is
1264    begin
1265       Key_Type'Write (Stream, Node.Key);
1266       Element_Type'Write (Stream, Node.Element);
1267    end Write_Node;
1268
1269 end Ada.Containers.Hashed_Maps;