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 (Target.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       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
 234
 235    begin
 236       if Node = null then
 237          raise Constraint_Error with "key not in map";
 238       end if;
 239
 240       declare
 241          HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
 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       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
 355
 356    begin
 357       if Node = null then
 358          raise Constraint_Error with
 359            "no element available because key not in map";
 360       end if;
 361
 362       return Node.Element;
 363    end Element;
 364
 365    function Element (Position : Cursor) return Element_Type is
 366    begin
 367       if Position.Node = null then
 368          raise Constraint_Error with
 369            "Position cursor of function Element equals No_Element";
 370       end if;
 371
 372       pragma Assert (Vet (Position), "bad cursor in function Element");
 373
 374       return Position.Node.Element;
 375    end Element;
 376
 377    -------------------------
 378    -- Equivalent_Key_Node --
 379    -------------------------
 380
 381    function Equivalent_Key_Node
 382      (Key  : Key_Type;
 383       Node : Node_Access) return Boolean is
 384    begin
 385       return Equivalent_Keys (Key, Node.Key);
 386    end Equivalent_Key_Node;
 387
 388    ---------------------
 389    -- Equivalent_Keys --
 390    ---------------------
 391
 392    function Equivalent_Keys (Left, Right : Cursor)
 393      return Boolean is
 394    begin
 395       if Left.Node = null then
 396          raise Constraint_Error with
 397            "Left cursor of Equivalent_Keys equals No_Element";
 398       end if;
 399
 400       if Right.Node = null then
 401          raise Constraint_Error with
 402            "Right cursor of Equivalent_Keys equals No_Element";
 403       end if;
 404
 405       pragma Assert (Vet (Left), "Left cursor of Equivalent_Keys is bad");
 406       pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad");
 407
 408       return Equivalent_Keys (Left.Node.Key, Right.Node.Key);
 409    end Equivalent_Keys;
 410
 411    function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is
 412    begin
 413       if Left.Node = null then
 414          raise Constraint_Error with
 415            "Left cursor of Equivalent_Keys equals No_Element";
 416       end if;
 417
 418       pragma Assert (Vet (Left), "Left cursor in Equivalent_Keys is bad");
 419
 420       return Equivalent_Keys (Left.Node.Key, Right);
 421    end Equivalent_Keys;
 422
 423    function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is
 424    begin
 425       if Right.Node = null then
 426          raise Constraint_Error with
 427            "Right cursor of Equivalent_Keys equals No_Element";
 428       end if;
 429
 430       pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad");
 431
 432       return Equivalent_Keys (Left, Right.Node.Key);
 433    end Equivalent_Keys;
 434
 435    -------------
 436    -- Exclude --
 437    -------------
 438
 439    procedure Exclude (Container : in out Map; Key : Key_Type) is
 440       X : Node_Access;
 441    begin
 442       Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
 443       Free (X);
 444    end Exclude;
 445
 446    --------------
 447    -- Finalize --
 448    --------------
 449
 450    procedure Finalize (Container : in out Map) is
 451    begin
 452       HT_Ops.Finalize (Container.HT);
 453    end Finalize;
 454
 455    procedure Finalize (Object : in out Iterator) is
 456    begin
 457       if Object.Container /= null then
 458          declare
 459             B : Natural renames Object.Container.all.HT.Busy;
 460          begin
 461             B := B - 1;
 462          end;
 463       end if;
 464    end Finalize;
 465
 466    procedure Finalize (Control : in out Reference_Control_Type) is
 467    begin
 468       if Control.Container /= null then
 469          declare
 470             HT : Hash_Table_Type renames Control.Container.all.HT;
 471             B  : Natural renames HT.Busy;
 472             L  : Natural renames HT.Lock;
 473          begin
 474             B := B - 1;
 475             L := L - 1;
 476          end;
 477
 478          Control.Container := null;
 479       end if;
 480    end Finalize;
 481
 482    ----------
 483    -- Find --
 484    ----------
 485
 486    function Find (Container : Map; Key : Key_Type) return Cursor is
 487       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
 488
 489    begin
 490       if Node = null then
 491          return No_Element;
 492       end if;
 493
 494       return Cursor'(Container'Unrestricted_Access, Node);
 495    end Find;
 496
 497    --------------------
 498    -- Find_Equal_Key --
 499    --------------------
 500
 501    function Find_Equal_Key
 502      (R_HT   : Hash_Table_Type;
 503       L_Node : Node_Access) return Boolean
 504    is
 505       R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key);
 506       R_Node  : Node_Access := R_HT.Buckets (R_Index);
 507
 508    begin
 509       while R_Node /= null loop
 510          if Equivalent_Keys (L_Node.Key, R_Node.Key) then
 511             return L_Node.Element = R_Node.Element;
 512          end if;
 513
 514          R_Node := R_Node.Next;
 515       end loop;
 516
 517       return False;
 518    end Find_Equal_Key;
 519
 520    -----------
 521    -- First --
 522    -----------
 523
 524    function First (Container : Map) return Cursor is
 525       Node : constant Node_Access := HT_Ops.First (Container.HT);
 526
 527    begin
 528       if Node = null then
 529          return No_Element;
 530       end if;
 531
 532       return Cursor'(Container'Unrestricted_Access, Node);
 533    end First;
 534
 535    function First (Object : Iterator) return Cursor is
 536    begin
 537       return Object.Container.First;
 538    end First;
 539
 540    ----------
 541    -- Free --
 542    ----------
 543
 544    procedure Free (X : in out Node_Access) is
 545       procedure Deallocate is
 546          new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 547    begin
 548       if X /= null then
 549          X.Next := X;     --  detect mischief (in Vet)
 550          Deallocate (X);
 551       end if;
 552    end Free;
 553
 554    -----------------
 555    -- Has_Element --
 556    -----------------
 557
 558    function Has_Element (Position : Cursor) return Boolean is
 559    begin
 560       pragma Assert (Vet (Position), "bad cursor in Has_Element");
 561       return Position.Node /= null;
 562    end Has_Element;
 563
 564    ---------------
 565    -- Hash_Node --
 566    ---------------
 567
 568    function Hash_Node (Node : Node_Access) return Hash_Type is
 569    begin
 570       return Hash (Node.Key);
 571    end Hash_Node;
 572
 573    -------------
 574    -- Include --
 575    -------------
 576
 577    procedure Include
 578      (Container : in out Map;
 579       Key       : Key_Type;
 580       New_Item  : Element_Type)
 581    is
 582       Position : Cursor;
 583       Inserted : Boolean;
 584
 585    begin
 586       Insert (Container, Key, New_Item, Position, Inserted);
 587
 588       if not Inserted then
 589          if Container.HT.Lock > 0 then
 590             raise Program_Error with
 591               "Include attempted to tamper with elements (map is locked)";
 592          end if;
 593
 594          Position.Node.Key := Key;
 595          Position.Node.Element := New_Item;
 596       end if;
 597    end Include;
 598
 599    ------------
 600    -- Insert --
 601    ------------
 602
 603    procedure Insert
 604      (Container : in out Map;
 605       Key       : Key_Type;
 606       Position  : out Cursor;
 607       Inserted  : out Boolean)
 608    is
 609       function New_Node (Next : Node_Access) return Node_Access;
 610       pragma Inline (New_Node);
 611
 612       procedure Local_Insert is
 613         new Key_Ops.Generic_Conditional_Insert (New_Node);
 614
 615       --------------
 616       -- New_Node --
 617       --------------
 618
 619       function New_Node (Next : Node_Access) return Node_Access is
 620       begin
 621          return new Node_Type'(Key     => Key,
 622                                Element => <>,
 623                                Next    => Next);
 624       end New_Node;
 625
 626       HT : Hash_Table_Type renames Container.HT;
 627
 628    --  Start of processing for Insert
 629
 630    begin
 631       if HT_Ops.Capacity (HT) = 0 then
 632          HT_Ops.Reserve_Capacity (HT, 1);
 633       end if;
 634
 635       Local_Insert (HT, Key, Position.Node, Inserted);
 636
 637       if Inserted
 638         and then HT.Length > HT_Ops.Capacity (HT)
 639       then
 640          HT_Ops.Reserve_Capacity (HT, HT.Length);
 641       end if;
 642
 643       Position.Container := Container'Unrestricted_Access;
 644    end Insert;
 645
 646    procedure Insert
 647      (Container : in out Map;
 648       Key       : Key_Type;
 649       New_Item  : Element_Type;
 650       Position  : out Cursor;
 651       Inserted  : out Boolean)
 652    is
 653       function New_Node (Next : Node_Access) return Node_Access;
 654       pragma Inline (New_Node);
 655
 656       procedure Local_Insert is
 657         new Key_Ops.Generic_Conditional_Insert (New_Node);
 658
 659       --------------
 660       -- New_Node --
 661       --------------
 662
 663       function New_Node (Next : Node_Access) return Node_Access is
 664       begin
 665          return new Node_Type'(Key, New_Item, Next);
 666       end New_Node;
 667
 668       HT : Hash_Table_Type renames Container.HT;
 669
 670    --  Start of processing for Insert
 671
 672    begin
 673       if HT_Ops.Capacity (HT) = 0 then
 674          HT_Ops.Reserve_Capacity (HT, 1);
 675       end if;
 676
 677       Local_Insert (HT, Key, Position.Node, Inserted);
 678
 679       if Inserted
 680         and then HT.Length > HT_Ops.Capacity (HT)
 681       then
 682          HT_Ops.Reserve_Capacity (HT, HT.Length);
 683       end if;
 684
 685       Position.Container := Container'Unrestricted_Access;
 686    end Insert;
 687
 688    procedure Insert
 689      (Container : in out Map;
 690       Key       : Key_Type;
 691       New_Item  : Element_Type)
 692    is
 693       Position : Cursor;
 694       pragma Unreferenced (Position);
 695
 696       Inserted : Boolean;
 697
 698    begin
 699       Insert (Container, Key, New_Item, Position, Inserted);
 700
 701       if not Inserted then
 702          raise Constraint_Error with
 703            "attempt to insert key already in map";
 704       end if;
 705    end Insert;
 706
 707    --------------
 708    -- Is_Empty --
 709    --------------
 710
 711    function Is_Empty (Container : Map) return Boolean is
 712    begin
 713       return Container.HT.Length = 0;
 714    end Is_Empty;
 715
 716    -------------
 717    -- Iterate --
 718    -------------
 719
 720    procedure Iterate
 721      (Container : Map;
 722       Process   : not null access procedure (Position : Cursor))
 723    is
 724       procedure Process_Node (Node : Node_Access);
 725       pragma Inline (Process_Node);
 726
 727       procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node);
 728
 729       ------------------
 730       -- Process_Node --
 731       ------------------
 732
 733       procedure Process_Node (Node : Node_Access) is
 734       begin
 735          Process (Cursor'(Container'Unrestricted_Access, Node));
 736       end Process_Node;
 737
 738       B : Natural renames Container'Unrestricted_Access.all.HT.Busy;
 739
 740    --  Start of processing for Iterate
 741
 742    begin
 743       B := B + 1;
 744
 745       begin
 746          Local_Iterate (Container.HT);
 747       exception
 748          when others =>
 749             B := B - 1;
 750             raise;
 751       end;
 752
 753       B := B - 1;
 754    end Iterate;
 755
 756    function Iterate
 757      (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class
 758    is
 759       B  : Natural renames Container'Unrestricted_Access.all.HT.Busy;
 760    begin
 761       return It : constant Iterator :=
 762         (Limited_Controlled with Container => Container'Unrestricted_Access)
 763       do
 764          B := B + 1;
 765       end return;
 766    end Iterate;
 767
 768    ---------
 769    -- Key --
 770    ---------
 771
 772    function Key (Position : Cursor) return Key_Type is
 773    begin
 774       if Position.Node = null then
 775          raise Constraint_Error with
 776            "Position cursor of function Key equals No_Element";
 777       end if;
 778
 779       pragma Assert (Vet (Position), "bad cursor in function Key");
 780
 781       return Position.Node.Key;
 782    end Key;
 783
 784    ------------
 785    -- Length --
 786    ------------
 787
 788    function Length (Container : Map) return Count_Type is
 789    begin
 790       return Container.HT.Length;
 791    end Length;
 792
 793    ----------
 794    -- Move --
 795    ----------
 796
 797    procedure Move
 798      (Target : in out Map;
 799       Source : in out Map)
 800    is
 801    begin
 802       HT_Ops.Move (Target => Target.HT, Source => Source.HT);
 803    end Move;
 804
 805    ----------
 806    -- Next --
 807    ----------
 808
 809    function Next (Node : Node_Access) return Node_Access is
 810    begin
 811       return Node.Next;
 812    end Next;
 813
 814    function Next (Position : Cursor) return Cursor is
 815    begin
 816       if Position.Node = null then
 817          return No_Element;
 818       end if;
 819
 820       pragma Assert (Vet (Position), "bad cursor in function Next");
 821
 822       declare
 823          HT   : Hash_Table_Type renames Position.Container.HT;
 824          Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
 825
 826       begin
 827          if Node = null then
 828             return No_Element;
 829          end if;
 830
 831          return Cursor'(Position.Container, Node);
 832       end;
 833    end Next;
 834
 835    procedure Next (Position : in out Cursor) is
 836    begin
 837       Position := Next (Position);
 838    end Next;
 839
 840    function Next
 841      (Object   : Iterator;
 842       Position : Cursor) return Cursor
 843    is
 844    begin
 845       if Position.Container = null then
 846          return No_Element;
 847       end if;
 848
 849       if Position.Container /= Object.Container then
 850          raise Program_Error with
 851            "Position cursor of Next designates wrong map";
 852       end if;
 853
 854       return Next (Position);
 855    end Next;
 856
 857    -------------------
 858    -- Query_Element --
 859    -------------------
 860
 861    procedure Query_Element
 862      (Position : Cursor;
 863       Process  : not null access
 864                    procedure (Key : Key_Type; Element : Element_Type))
 865    is
 866    begin
 867       if Position.Node = null then
 868          raise Constraint_Error with
 869            "Position cursor of Query_Element equals No_Element";
 870       end if;
 871
 872       pragma Assert (Vet (Position), "bad cursor in Query_Element");
 873
 874       declare
 875          M  : Map renames Position.Container.all;
 876          HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
 877
 878          B : Natural renames HT.Busy;
 879          L : Natural renames HT.Lock;
 880
 881       begin
 882          B := B + 1;
 883          L := L + 1;
 884
 885          declare
 886             K : Key_Type renames Position.Node.Key;
 887             E : Element_Type renames Position.Node.Element;
 888
 889          begin
 890             Process (K, E);
 891          exception
 892             when others =>
 893                L := L - 1;
 894                B := B - 1;
 895                raise;
 896          end;
 897
 898          L := L - 1;
 899          B := B - 1;
 900       end;
 901    end Query_Element;
 902
 903    ----------
 904    -- Read --
 905    ----------
 906
 907    procedure Read
 908      (Stream    : not null access Root_Stream_Type'Class;
 909       Container : out Map)
 910    is
 911    begin
 912       Read_Nodes (Stream, Container.HT);
 913    end Read;
 914
 915    procedure Read
 916      (Stream : not null access Root_Stream_Type'Class;
 917       Item   : out Cursor)
 918    is
 919    begin
 920       raise Program_Error with "attempt to stream map cursor";
 921    end Read;
 922
 923    procedure Read
 924      (Stream : not null access Root_Stream_Type'Class;
 925       Item   : out Reference_Type)
 926    is
 927    begin
 928       raise Program_Error with "attempt to stream reference";
 929    end Read;
 930
 931    procedure Read
 932      (Stream : not null access Root_Stream_Type'Class;
 933       Item   : out Constant_Reference_Type)
 934    is
 935    begin
 936       raise Program_Error with "attempt to stream reference";
 937    end Read;
 938
 939    ---------------
 940    -- Reference --
 941    ---------------
 942
 943    function Reference
 944      (Container : aliased in out Map;
 945       Position  : Cursor) return Reference_Type
 946    is
 947    begin
 948       if Position.Container = null then
 949          raise Constraint_Error with
 950            "Position cursor has no element";
 951       end if;
 952
 953       if Position.Container /= Container'Unrestricted_Access then
 954          raise Program_Error with
 955            "Position cursor designates wrong map";
 956       end if;
 957
 958       pragma Assert
 959         (Vet (Position),
 960          "Position cursor in function Reference is bad");
 961
 962       declare
 963          HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
 964          B  : Natural renames HT.Busy;
 965          L  : Natural renames HT.Lock;
 966       begin
 967          return R : constant Reference_Type :=
 968            (Element => Position.Node.Element'Access,
 969             Control => (Controlled with Position.Container))
 970          do
 971             B := B + 1;
 972             L := L + 1;
 973          end return;
 974       end;
 975    end Reference;
 976
 977    function Reference
 978      (Container : aliased in out Map;
 979       Key       : Key_Type) return Reference_Type
 980    is
 981       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
 982
 983    begin
 984       if Node = null then
 985          raise Constraint_Error with "key not in map";
 986       end if;
 987
 988       declare
 989          HT : Hash_Table_Type renames Container'Unrestricted_Access.all.HT;
 990          B  : Natural renames HT.Busy;
 991          L  : Natural renames HT.Lock;
 992       begin
 993          return R : constant Reference_Type :=
 994            (Element => Node.Element'Access,
 995             Control => (Controlled with Container'Unrestricted_Access))
 996          do
 997             B := B + 1;
 998             L := L + 1;
 999          end return;
1000       end;
1001    end Reference;
1002
1003    ---------------
1004    -- Read_Node --
1005    ---------------
1006
1007    function Read_Node
1008      (Stream : not null access Root_Stream_Type'Class) return Node_Access
1009    is
1010       Node : Node_Access := new Node_Type;
1011
1012    begin
1013       Key_Type'Read (Stream, Node.Key);
1014       Element_Type'Read (Stream, Node.Element);
1015       return Node;
1016
1017    exception
1018       when others =>
1019          Free (Node);
1020          raise;
1021    end Read_Node;
1022
1023    -------------
1024    -- Replace --
1025    -------------
1026
1027    procedure Replace
1028      (Container : in out Map;
1029       Key       : Key_Type;
1030       New_Item  : Element_Type)
1031    is
1032       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
1033
1034    begin
1035       if Node = null then
1036          raise Constraint_Error with
1037            "attempt to replace key not in map";
1038       end if;
1039
1040       if Container.HT.Lock > 0 then
1041          raise Program_Error with
1042            "Replace attempted to tamper with elements (map is locked)";
1043       end if;
1044
1045       Node.Key := Key;
1046       Node.Element := New_Item;
1047    end Replace;
1048
1049    ---------------------
1050    -- Replace_Element --
1051    ---------------------
1052
1053    procedure Replace_Element
1054      (Container : in out Map;
1055       Position  : Cursor;
1056       New_Item  : Element_Type)
1057    is
1058    begin
1059       if Position.Node = null then
1060          raise Constraint_Error with
1061            "Position cursor of Replace_Element equals No_Element";
1062       end if;
1063
1064       if Position.Container /= Container'Unrestricted_Access then
1065          raise Program_Error with
1066            "Position cursor of Replace_Element designates wrong map";
1067       end if;
1068
1069       if Position.Container.HT.Lock > 0 then
1070          raise Program_Error with
1071            "Replace_Element attempted to tamper with elements (map is locked)";
1072       end if;
1073
1074       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1075
1076       Position.Node.Element := New_Item;
1077    end Replace_Element;
1078
1079    ----------------------
1080    -- Reserve_Capacity --
1081    ----------------------
1082
1083    procedure Reserve_Capacity
1084      (Container : in out Map;
1085       Capacity  : Count_Type)
1086    is
1087    begin
1088       HT_Ops.Reserve_Capacity (Container.HT, Capacity);
1089    end Reserve_Capacity;
1090
1091    --------------
1092    -- Set_Next --
1093    --------------
1094
1095    procedure Set_Next (Node : Node_Access; Next : Node_Access) is
1096    begin
1097       Node.Next := Next;
1098    end Set_Next;
1099
1100    --------------------
1101    -- Update_Element --
1102    --------------------
1103
1104    procedure Update_Element
1105      (Container : in out Map;
1106       Position  : Cursor;
1107       Process   : not null access procedure (Key     : Key_Type;
1108                                              Element : in out Element_Type))
1109    is
1110    begin
1111       if Position.Node = null then
1112          raise Constraint_Error with
1113            "Position cursor of Update_Element equals No_Element";
1114       end if;
1115
1116       if Position.Container /= Container'Unrestricted_Access then
1117          raise Program_Error with
1118            "Position cursor of Update_Element designates wrong map";
1119       end if;
1120
1121       pragma Assert (Vet (Position), "bad cursor in Update_Element");
1122
1123       declare
1124          HT : Hash_Table_Type renames Container.HT;
1125          B  : Natural renames HT.Busy;
1126          L  : Natural renames HT.Lock;
1127
1128       begin
1129          B := B + 1;
1130          L := L + 1;
1131
1132          declare
1133             K : Key_Type renames Position.Node.Key;
1134             E : Element_Type renames Position.Node.Element;
1135
1136          begin
1137             Process (K, E);
1138
1139          exception
1140             when others =>
1141                L := L - 1;
1142                B := B - 1;
1143                raise;
1144          end;
1145
1146          L := L - 1;
1147          B := B - 1;
1148       end;
1149    end Update_Element;
1150
1151    ---------
1152    -- Vet --
1153    ---------
1154
1155    function Vet (Position : Cursor) return Boolean is
1156    begin
1157       if Position.Node = null then
1158          return Position.Container = null;
1159       end if;
1160
1161       if Position.Container = null then
1162          return False;
1163       end if;
1164
1165       if Position.Node.Next = Position.Node then
1166          return False;
1167       end if;
1168
1169       declare
1170          HT : Hash_Table_Type renames Position.Container.HT;
1171          X  : Node_Access;
1172
1173       begin
1174          if HT.Length = 0 then
1175             return False;
1176          end if;
1177
1178          if HT.Buckets = null
1179            or else HT.Buckets'Length = 0
1180          then
1181             return False;
1182          end if;
1183
1184          X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key));
1185
1186          for J in 1 .. HT.Length loop
1187             if X = Position.Node then
1188                return True;
1189             end if;
1190
1191             if X = null then
1192                return False;
1193             end if;
1194
1195             if X = X.Next then  --  to prevent unnecessary looping
1196                return False;
1197             end if;
1198
1199             X := X.Next;
1200          end loop;
1201
1202          return False;
1203       end;
1204    end Vet;
1205
1206    -----------
1207    -- Write --
1208    -----------
1209
1210    procedure Write
1211      (Stream    : not null access Root_Stream_Type'Class;
1212       Container : Map)
1213    is
1214    begin
1215       Write_Nodes (Stream, Container.HT);
1216    end Write;
1217
1218    procedure Write
1219      (Stream : not null access Root_Stream_Type'Class;
1220       Item   : Cursor)
1221    is
1222    begin
1223       raise Program_Error with "attempt to stream map cursor";
1224    end Write;
1225
1226    procedure Write
1227      (Stream : not null access Root_Stream_Type'Class;
1228       Item   : Reference_Type)
1229    is
1230    begin
1231       raise Program_Error with "attempt to stream reference";
1232    end Write;
1233
1234    procedure Write
1235      (Stream : not null access Root_Stream_Type'Class;
1236       Item   : Constant_Reference_Type)
1237    is
1238    begin
1239       raise Program_Error with "attempt to stream reference";
1240    end Write;
1241
1242    ----------------
1243    -- Write_Node --
1244    ----------------
1245
1246    procedure Write_Node
1247      (Stream : not null access Root_Stream_Type'Class;
1248       Node   : Node_Access)
1249    is
1250    begin
1251       Key_Type'Write (Stream, Node.Key);
1252       Element_Type'Write (Stream, Node.Element);
1253    end Write_Node;
1254
1255 end Ada.Containers.Hashed_Maps;