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          begin
 891             Process (K, E);
 892          exception
 893             when others =>
 894                L := L - 1;
 895                B := B - 1;
 896                raise;
 897          end;
 898
 899          L := L - 1;
 900          B := B - 1;
 901       end;
 902    end Query_Element;
 903
 904    ----------
 905    -- Read --
 906    ----------
 907
 908    procedure Read
 909      (Stream    : not null access Root_Stream_Type'Class;
 910       Container : out Map)
 911    is
 912    begin
 913       Read_Nodes (Stream, Container.HT);
 914    end Read;
 915
 916    procedure Read
 917      (Stream : not null access Root_Stream_Type'Class;
 918       Item   : out Cursor)
 919    is
 920    begin
 921       raise Program_Error with "attempt to stream map cursor";
 922    end Read;
 923
 924    procedure Read
 925      (Stream : not null access Root_Stream_Type'Class;
 926       Item   : out Reference_Type)
 927    is
 928    begin
 929       raise Program_Error with "attempt to stream reference";
 930    end Read;
 931
 932    procedure Read
 933      (Stream : not null access Root_Stream_Type'Class;
 934       Item   : out Constant_Reference_Type)
 935    is
 936    begin
 937       raise Program_Error with "attempt to stream reference";
 938    end Read;
 939
 940    ---------------
 941    -- Reference --
 942    ---------------
 943
 944    function Reference
 945      (Container : aliased in out Map;
 946       Position  : Cursor) return Reference_Type
 947    is
 948    begin
 949       if Position.Container = null then
 950          raise Constraint_Error with
 951            "Position cursor has no element";
 952       end if;
 953
 954       if Position.Container /= Container'Unrestricted_Access then
 955          raise Program_Error with
 956            "Position cursor designates wrong map";
 957       end if;
 958
 959       pragma Assert
 960         (Vet (Position),
 961          "Position cursor in function Reference is bad");
 962
 963       declare
 964          HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
 965          B  : Natural renames HT.Busy;
 966          L  : Natural renames HT.Lock;
 967       begin
 968          return R : constant Reference_Type :=
 969            (Element => Position.Node.Element'Access,
 970             Control => (Controlled with Position.Container))
 971          do
 972             B := B + 1;
 973             L := L + 1;
 974          end return;
 975       end;
 976    end Reference;
 977
 978    function Reference
 979      (Container : aliased in out Map;
 980       Key       : Key_Type) return Reference_Type
 981    is
 982       HT   : Hash_Table_Type renames Container.HT;
 983       Node : constant Node_Access := Key_Ops.Find (HT, Key);
 984
 985    begin
 986       if Node = null then
 987          raise Constraint_Error with "key not in map";
 988       end if;
 989
 990       declare
 991          B  : Natural renames HT.Busy;
 992          L  : Natural renames HT.Lock;
 993       begin
 994          return R : constant Reference_Type :=
 995            (Element => Node.Element'Access,
 996             Control => (Controlled with Container'Unrestricted_Access))
 997          do
 998             B := B + 1;
 999             L := L + 1;
1000          end return;
1001       end;
1002    end Reference;
1003
1004    ---------------
1005    -- Read_Node --
1006    ---------------
1007
1008    function Read_Node
1009      (Stream : not null access Root_Stream_Type'Class) return Node_Access
1010    is
1011       Node : Node_Access := new Node_Type;
1012
1013    begin
1014       Key_Type'Read (Stream, Node.Key);
1015       Element_Type'Read (Stream, Node.Element);
1016       return Node;
1017
1018    exception
1019       when others =>
1020          Free (Node);
1021          raise;
1022    end Read_Node;
1023
1024    -------------
1025    -- Replace --
1026    -------------
1027
1028    procedure Replace
1029      (Container : in out Map;
1030       Key       : Key_Type;
1031       New_Item  : Element_Type)
1032    is
1033       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
1034
1035    begin
1036       if Node = null then
1037          raise Constraint_Error with
1038            "attempt to replace key not in map";
1039       end if;
1040
1041       if Container.HT.Lock > 0 then
1042          raise Program_Error with
1043            "Replace attempted to tamper with elements (map is locked)";
1044       end if;
1045
1046       Node.Key := Key;
1047       Node.Element := New_Item;
1048    end Replace;
1049
1050    ---------------------
1051    -- Replace_Element --
1052    ---------------------
1053
1054    procedure Replace_Element
1055      (Container : in out Map;
1056       Position  : Cursor;
1057       New_Item  : Element_Type)
1058    is
1059    begin
1060       if Position.Node = null then
1061          raise Constraint_Error with
1062            "Position cursor of Replace_Element equals No_Element";
1063       end if;
1064
1065       if Position.Container /= Container'Unrestricted_Access then
1066          raise Program_Error with
1067            "Position cursor of Replace_Element designates wrong map";
1068       end if;
1069
1070       if Position.Container.HT.Lock > 0 then
1071          raise Program_Error with
1072            "Replace_Element attempted to tamper with elements (map is locked)";
1073       end if;
1074
1075       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1076
1077       Position.Node.Element := New_Item;
1078    end Replace_Element;
1079
1080    ----------------------
1081    -- Reserve_Capacity --
1082    ----------------------
1083
1084    procedure Reserve_Capacity
1085      (Container : in out Map;
1086       Capacity  : Count_Type)
1087    is
1088    begin
1089       HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1090    end Reserve_Capacity;
1091
1092    --------------
1093    -- Set_Next --
1094    --------------
1095
1096    procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1097    begin
1098       Node.Next := Next;
1099    end Set_Next;
1100
1101    --------------------
1102    -- Update_Element --
1103    --------------------
1104
1105    procedure Update_Element
1106      (Container : in out Map;
1107       Position  : Cursor;
1108       Process   : not null access procedure (Key     : Key_Type;
1109                                              Element : in out Element_Type))
1110    is
1111    begin
1112       if Position.Node = null then
1113          raise Constraint_Error with
1114            "Position cursor of Update_Element equals No_Element";
1115       end if;
1116
1117       if Position.Container /= Container'Unrestricted_Access then
1118          raise Program_Error with
1119            "Position cursor of Update_Element designates wrong map";
1120       end if;
1121
1122       pragma Assert (Vet (Position), "bad cursor in Update_Element");
1123
1124       declare
1125          HT : Hash_Table_Type renames Container.HT;
1126          B  : Natural renames HT.Busy;
1127          L  : Natural renames HT.Lock;
1128
1129       begin
1130          B := B + 1;
1131          L := L + 1;
1132
1133          declare
1134             K : Key_Type renames Position.Node.Key;
1135             E : Element_Type renames Position.Node.Element;
1136          begin
1137             Process (K, E);
1138          exception
1139             when others =>
1140                L := L - 1;
1141                B := B - 1;
1142                raise;
1143          end;
1144
1145          L := L - 1;
1146          B := B - 1;
1147       end;
1148    end Update_Element;
1149
1150    ---------
1151    -- Vet --
1152    ---------
1153
1154    function Vet (Position : Cursor) return Boolean is
1155    begin
1156       if Position.Node = null then
1157          return Position.Container = null;
1158       end if;
1159
1160       if Position.Container = null then
1161          return False;
1162       end if;
1163
1164       if Position.Node.Next = Position.Node then
1165          return False;
1166       end if;
1167
1168       declare
1169          HT : Hash_Table_Type renames Position.Container.HT;
1170          X  : Node_Access;
1171
1172       begin
1173          if HT.Length = 0 then
1174             return False;
1175          end if;
1176
1177          if HT.Buckets = null
1178            or else HT.Buckets'Length = 0
1179          then
1180             return False;
1181          end if;
1182
1183          X := HT.Buckets (Key_Ops.Checked_Index (HT, Position.Node.Key));
1184
1185          for J in 1 .. HT.Length loop
1186             if X = Position.Node then
1187                return True;
1188             end if;
1189
1190             if X = null then
1191                return False;
1192             end if;
1193
1194             if X = X.Next then  --  to prevent unnecessary looping
1195                return False;
1196             end if;
1197
1198             X := X.Next;
1199          end loop;
1200
1201          return False;
1202       end;
1203    end Vet;
1204
1205    -----------
1206    -- Write --
1207    -----------
1208
1209    procedure Write
1210      (Stream    : not null access Root_Stream_Type'Class;
1211       Container : Map)
1212    is
1213    begin
1214       Write_Nodes (Stream, Container.HT);
1215    end Write;
1216
1217    procedure Write
1218      (Stream : not null access Root_Stream_Type'Class;
1219       Item   : Cursor)
1220    is
1221    begin
1222       raise Program_Error with "attempt to stream map cursor";
1223    end Write;
1224
1225    procedure Write
1226      (Stream : not null access Root_Stream_Type'Class;
1227       Item   : Reference_Type)
1228    is
1229    begin
1230       raise Program_Error with "attempt to stream reference";
1231    end Write;
1232
1233    procedure Write
1234      (Stream : not null access Root_Stream_Type'Class;
1235       Item   : Constant_Reference_Type)
1236    is
1237    begin
1238       raise Program_Error with "attempt to stream reference";
1239    end Write;
1240
1241    ----------------
1242    -- Write_Node --
1243    ----------------
1244
1245    procedure Write_Node
1246      (Stream : not null access Root_Stream_Type'Class;
1247       Node   : Node_Access)
1248    is
1249    begin
1250       Key_Type'Write (Stream, Node.Key);
1251       Element_Type'Write (Stream, Node.Element);
1252    end Write_Node;
1253
1254 end Ada.Containers.Hashed_Maps;