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