gcc/ada/libgnat/a-cbhama.adb

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