gcc/ada/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-2015, 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          New_Item : Element_Type;
 582          pragma Unmodified (New_Item);
 583          --  Default-initialized element (ok to reference, see below)
 584
 585       begin
 586          Node.Key := Key;
 587
 588          --  There is no explicit element provided, but in an instance the
 589          --  element type may be a scalar with a Default_Value aspect, or a
 590          --  composite type with such a scalar component, or components with
 591          --  default initialization, so insert a possibly initialized element
 592          --  under the given key.
 593
 594          Node.Element := New_Item;
 595       end Assign_Key;
 596
 597       --------------
 598       -- New_Node --
 599       --------------
 600
 601       function New_Node return Count_Type is
 602          Result : Count_Type;
 603       begin
 604          Allocate (Container, Result);
 605          return Result;
 606       end New_Node;
 607
 608    --  Start of processing for Insert
 609
 610    begin
 611       --  The buckets array length is specified by the user as a discriminant
 612       --  of the container type, so it is possible for the buckets array to
 613       --  have a length of zero. We must check for this case specifically, in
 614       --  order to prevent divide-by-zero errors later, when we compute the
 615       --  buckets array index value for a key, given its hash value.
 616
 617       if Checks and then Container.Buckets'Length = 0 then
 618          raise Capacity_Error with "No capacity for insertion";
 619       end if;
 620
 621       Local_Insert (Container, Key, Position.Node, Inserted);
 622       Position.Container := Container'Unchecked_Access;
 623    end Insert;
 624
 625    procedure Insert
 626      (Container : in out Map;
 627       Key       : Key_Type;
 628       New_Item  : Element_Type;
 629       Position  : out Cursor;
 630       Inserted  : out Boolean)
 631    is
 632       procedure Assign_Key (Node : in out Node_Type);
 633       pragma Inline (Assign_Key);
 634
 635       function New_Node return Count_Type;
 636       pragma Inline (New_Node);
 637
 638       procedure Local_Insert is
 639         new Key_Ops.Generic_Conditional_Insert (New_Node);
 640
 641       procedure Allocate is
 642          new HT_Ops.Generic_Allocate (Assign_Key);
 643
 644       -----------------
 645       --  Assign_Key --
 646       -----------------
 647
 648       procedure Assign_Key (Node : in out Node_Type) is
 649       begin
 650          Node.Key := Key;
 651          Node.Element := New_Item;
 652       end Assign_Key;
 653
 654       --------------
 655       -- New_Node --
 656       --------------
 657
 658       function New_Node return Count_Type is
 659          Result : Count_Type;
 660       begin
 661          Allocate (Container, Result);
 662          return Result;
 663       end New_Node;
 664
 665    --  Start of processing for Insert
 666
 667    begin
 668       --  The buckets array length is specified by the user as a discriminant
 669       --  of the container type, so it is possible for the buckets array to
 670       --  have a length of zero. We must check for this case specifically, in
 671       --  order to prevent divide-by-zero errors later, when we compute the
 672       --  buckets array index value for a key, given its hash value.
 673
 674       if Checks and then Container.Buckets'Length = 0 then
 675          raise Capacity_Error with "No capacity for insertion";
 676       end if;
 677
 678       Local_Insert (Container, Key, Position.Node, Inserted);
 679       Position.Container := Container'Unchecked_Access;
 680    end Insert;
 681
 682    procedure Insert
 683      (Container : in out Map;
 684       Key       : Key_Type;
 685       New_Item  : Element_Type)
 686    is
 687       Position : Cursor;
 688       pragma Unreferenced (Position);
 689
 690       Inserted : Boolean;
 691
 692    begin
 693       Insert (Container, Key, New_Item, Position, Inserted);
 694
 695       if Checks and then not Inserted then
 696          raise Constraint_Error with
 697            "attempt to insert key already in map";
 698       end if;
 699    end Insert;
 700
 701    --------------
 702    -- Is_Empty --
 703    --------------
 704
 705    function Is_Empty (Container : Map) return Boolean is
 706    begin
 707       return Container.Length = 0;
 708    end Is_Empty;
 709
 710    -------------
 711    -- Iterate --
 712    -------------
 713
 714    procedure Iterate
 715      (Container : Map;
 716       Process   : not null access procedure (Position : Cursor))
 717    is
 718       procedure Process_Node (Node : Count_Type);
 719       pragma Inline (Process_Node);
 720
 721       procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node);
 722
 723       ------------------
 724       -- Process_Node --
 725       ------------------
 726
 727       procedure Process_Node (Node : Count_Type) is
 728       begin
 729          Process (Cursor'(Container'Unrestricted_Access, Node));
 730       end Process_Node;
 731
 732       Busy : With_Busy (Container.TC'Unrestricted_Access);
 733
 734    --  Start of processing for Iterate
 735
 736    begin
 737       Local_Iterate (Container);
 738    end Iterate;
 739
 740    function Iterate
 741      (Container : Map) return Map_Iterator_Interfaces.Forward_Iterator'Class
 742    is
 743    begin
 744       return It : constant Iterator :=
 745         (Limited_Controlled with
 746            Container => Container'Unrestricted_Access)
 747       do
 748          Busy (Container.TC'Unrestricted_Access.all);
 749       end return;
 750    end Iterate;
 751
 752    ---------
 753    -- Key --
 754    ---------
 755
 756    function Key (Position : Cursor) return Key_Type is
 757    begin
 758       if Checks and then Position.Node = 0 then
 759          raise Constraint_Error with
 760            "Position cursor of function Key equals No_Element";
 761       end if;
 762
 763       pragma Assert (Vet (Position), "bad cursor in function Key");
 764
 765       return Position.Container.Nodes (Position.Node).Key;
 766    end Key;
 767
 768    ------------
 769    -- Length --
 770    ------------
 771
 772    function Length (Container : Map) return Count_Type is
 773    begin
 774       return Container.Length;
 775    end Length;
 776
 777    ----------
 778    -- Move --
 779    ----------
 780
 781    procedure Move
 782      (Target : in out Map;
 783       Source : in out Map)
 784    is
 785    begin
 786       if Target'Address = Source'Address then
 787          return;
 788       end if;
 789
 790       TC_Check (Source.TC);
 791
 792       Target.Assign (Source);
 793       Source.Clear;
 794    end Move;
 795
 796    ----------
 797    -- Next --
 798    ----------
 799
 800    function Next (Node : Node_Type) return Count_Type is
 801    begin
 802       return Node.Next;
 803    end Next;
 804
 805    function Next (Position : Cursor) return Cursor is
 806    begin
 807       if Position.Node = 0 then
 808          return No_Element;
 809       end if;
 810
 811       pragma Assert (Vet (Position), "bad cursor in function Next");
 812
 813       declare
 814          M    : Map renames Position.Container.all;
 815          Node : constant Count_Type := HT_Ops.Next (M, Position.Node);
 816       begin
 817          if Node = 0 then
 818             return No_Element;
 819          else
 820             return Cursor'(Position.Container, Node);
 821          end if;
 822       end;
 823    end Next;
 824
 825    procedure Next (Position : in out Cursor) is
 826    begin
 827       Position := Next (Position);
 828    end Next;
 829
 830    function Next
 831      (Object   : Iterator;
 832       Position : Cursor) return Cursor
 833    is
 834    begin
 835       if Position.Container = null then
 836          return No_Element;
 837       end if;
 838
 839       if Checks and then Position.Container /= Object.Container then
 840          raise Program_Error with
 841            "Position cursor of Next designates wrong map";
 842       end if;
 843
 844       return Next (Position);
 845    end Next;
 846
 847    ----------------------
 848    -- Pseudo_Reference --
 849    ----------------------
 850
 851    function Pseudo_Reference
 852      (Container : aliased Map'Class) return Reference_Control_Type
 853    is
 854       TC : constant Tamper_Counts_Access :=
 855         Container.TC'Unrestricted_Access;
 856    begin
 857       return R : constant Reference_Control_Type := (Controlled with TC) do
 858          Lock (TC.all);
 859       end return;
 860    end Pseudo_Reference;
 861
 862    -------------------
 863    -- Query_Element --
 864    -------------------
 865
 866    procedure Query_Element
 867      (Position : Cursor;
 868       Process  : not null access
 869                    procedure (Key : Key_Type; Element : Element_Type))
 870    is
 871    begin
 872       if Checks and then Position.Node = 0 then
 873          raise Constraint_Error with
 874            "Position cursor of Query_Element equals No_Element";
 875       end if;
 876
 877       pragma Assert (Vet (Position), "bad cursor in Query_Element");
 878
 879       declare
 880          M : Map renames Position.Container.all;
 881          N : Node_Type renames M.Nodes (Position.Node);
 882          Lock : With_Lock (M.TC'Unrestricted_Access);
 883       begin
 884          Process (N.Key, N.Element);
 885       end;
 886    end Query_Element;
 887
 888    ----------
 889    -- Read --
 890    ----------
 891
 892    procedure Read
 893      (Stream    : not null access Root_Stream_Type'Class;
 894       Container : out Map)
 895    is
 896       function Read_Node
 897         (Stream : not null access Root_Stream_Type'Class) return Count_Type;
 898       --  pragma Inline (Read_Node);  ???
 899
 900       procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node);
 901
 902       ---------------
 903       -- Read_Node --
 904       ---------------
 905
 906       function Read_Node
 907         (Stream : not null access Root_Stream_Type'Class) return Count_Type
 908       is
 909          procedure Read_Element (Node : in out Node_Type);
 910          --  pragma Inline (Read_Element);  ???
 911
 912          procedure Allocate is
 913             new HT_Ops.Generic_Allocate (Read_Element);
 914
 915          procedure Read_Element (Node : in out Node_Type) is
 916          begin
 917             Key_Type'Read (Stream, Node.Key);
 918             Element_Type'Read (Stream, Node.Element);
 919          end Read_Element;
 920
 921          Node : Count_Type;
 922
 923       --  Start of processing for Read_Node
 924
 925       begin
 926          Allocate (Container, Node);
 927          return Node;
 928       end Read_Node;
 929
 930    --  Start of processing for Read
 931
 932    begin
 933       Read_Nodes (Stream, Container);
 934    end Read;
 935
 936    procedure Read
 937      (Stream : not null access Root_Stream_Type'Class;
 938       Item   : out Cursor)
 939    is
 940    begin
 941       raise Program_Error with "attempt to stream map cursor";
 942    end Read;
 943
 944    procedure Read
 945      (Stream : not null access Root_Stream_Type'Class;
 946       Item   : out Reference_Type)
 947    is
 948    begin
 949       raise Program_Error with "attempt to stream reference";
 950    end Read;
 951
 952    procedure Read
 953      (Stream : not null access Root_Stream_Type'Class;
 954       Item   : out Constant_Reference_Type)
 955    is
 956    begin
 957       raise Program_Error with "attempt to stream reference";
 958    end Read;
 959
 960    ---------------
 961    -- Reference --
 962    ---------------
 963
 964    function Reference
 965      (Container : aliased in out Map;
 966       Position  : Cursor) return Reference_Type
 967    is
 968    begin
 969       if Checks and then Position.Container = null then
 970          raise Constraint_Error with
 971            "Position cursor has no element";
 972       end if;
 973
 974       if Checks and then Position.Container /= Container'Unrestricted_Access
 975       then
 976          raise Program_Error with
 977            "Position cursor designates wrong map";
 978       end if;
 979
 980       pragma Assert (Vet (Position),
 981                      "Position cursor in function Reference is bad");
 982
 983       declare
 984          N : Node_Type renames Container.Nodes (Position.Node);
 985          TC : constant Tamper_Counts_Access :=
 986            Container.TC'Unrestricted_Access;
 987       begin
 988          return R : constant Reference_Type :=
 989            (Element => N.Element'Access,
 990             Control => (Controlled with TC))
 991          do
 992             Lock (TC.all);
 993          end return;
 994       end;
 995    end Reference;
 996
 997    function Reference
 998      (Container : aliased in out Map;
 999       Key       : Key_Type) return Reference_Type
1000    is
1001       Node : constant Count_Type := Key_Ops.Find (Container, Key);
1002
1003    begin
1004       if Checks and then Node = 0 then
1005          raise Constraint_Error with "key not in map";
1006       end if;
1007
1008       declare
1009          N : Node_Type renames Container.Nodes (Node);
1010          TC : constant Tamper_Counts_Access :=
1011            Container.TC'Unrestricted_Access;
1012       begin
1013          return R : constant Reference_Type :=
1014            (Element => N.Element'Access,
1015             Control => (Controlled with TC))
1016          do
1017             Lock (TC.all);
1018          end return;
1019       end;
1020    end Reference;
1021
1022    -------------
1023    -- Replace --
1024    -------------
1025
1026    procedure Replace
1027      (Container : in out Map;
1028       Key       : Key_Type;
1029       New_Item  : Element_Type)
1030    is
1031       Node : constant Count_Type := Key_Ops.Find (Container, Key);
1032
1033    begin
1034       if Checks and then Node = 0 then
1035          raise Constraint_Error with
1036            "attempt to replace key not in map";
1037       end if;
1038
1039       TE_Check (Container.TC);
1040
1041       declare
1042          N : Node_Type renames Container.Nodes (Node);
1043       begin
1044          N.Key := Key;
1045          N.Element := New_Item;
1046       end;
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 Checks and then Position.Node = 0 then
1060          raise Constraint_Error with
1061            "Position cursor of Replace_Element equals No_Element";
1062       end if;
1063
1064       if Checks and then Position.Container /= Container'Unrestricted_Access
1065       then
1066          raise Program_Error with
1067            "Position cursor of Replace_Element designates wrong map";
1068       end if;
1069
1070       TE_Check (Position.Container.TC);
1071
1072       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
1073
1074       Container.Nodes (Position.Node).Element := New_Item;
1075    end Replace_Element;
1076
1077    ----------------------
1078    -- Reserve_Capacity --
1079    ----------------------
1080
1081    procedure Reserve_Capacity
1082      (Container : in out Map;
1083       Capacity  : Count_Type)
1084    is
1085    begin
1086       if Checks and then Capacity > Container.Capacity then
1087          raise Capacity_Error with "requested capacity is too large";
1088       end if;
1089    end Reserve_Capacity;
1090
1091    --------------
1092    -- Set_Next --
1093    --------------
1094
1095    procedure Set_Next (Node : in out Node_Type; Next : Count_Type) 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 Checks and then Position.Node = 0 then
1112          raise Constraint_Error with
1113            "Position cursor of Update_Element equals No_Element";
1114       end if;
1115
1116       if Checks and then Position.Container /= Container'Unrestricted_Access
1117       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          N : Node_Type renames Container.Nodes (Position.Node);
1126          Lock : With_Lock (Container.TC'Unrestricted_Access);
1127       begin
1128          Process (N.Key, N.Element);
1129       end;
1130    end Update_Element;
1131
1132    ---------
1133    -- Vet --
1134    ---------
1135
1136    function Vet (Position : Cursor) return Boolean is
1137    begin
1138       if Position.Node = 0 then
1139          return Position.Container = null;
1140       end if;
1141
1142       if Position.Container = null then
1143          return False;
1144       end if;
1145
1146       declare
1147          M : Map renames Position.Container.all;
1148          X : Count_Type;
1149
1150       begin
1151          if M.Length = 0 then
1152             return False;
1153          end if;
1154
1155          if M.Capacity = 0 then
1156             return False;
1157          end if;
1158
1159          if M.Buckets'Length = 0 then
1160             return False;
1161          end if;
1162
1163          if Position.Node > M.Capacity then
1164             return False;
1165          end if;
1166
1167          if M.Nodes (Position.Node).Next = Position.Node then
1168             return False;
1169          end if;
1170
1171          X := M.Buckets (Key_Ops.Checked_Index
1172                           (M, M.Nodes (Position.Node).Key));
1173
1174          for J in 1 .. M.Length loop
1175             if X = Position.Node then
1176                return True;
1177             end if;
1178
1179             if X = 0 then
1180                return False;
1181             end if;
1182
1183             if X = M.Nodes (X).Next then  --  to prevent unnecessary looping
1184                return False;
1185             end if;
1186
1187             X := M.Nodes (X).Next;
1188          end loop;
1189
1190          return False;
1191       end;
1192    end Vet;
1193
1194    -----------
1195    -- Write --
1196    -----------
1197
1198    procedure Write
1199      (Stream    : not null access Root_Stream_Type'Class;
1200       Container : Map)
1201    is
1202       procedure Write_Node
1203         (Stream : not null access Root_Stream_Type'Class;
1204          Node   : Node_Type);
1205       pragma Inline (Write_Node);
1206
1207       procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
1208
1209       ----------------
1210       -- Write_Node --
1211       ----------------
1212
1213       procedure Write_Node
1214         (Stream : not null access Root_Stream_Type'Class;
1215          Node   : Node_Type)
1216       is
1217       begin
1218          Key_Type'Write (Stream, Node.Key);
1219          Element_Type'Write (Stream, Node.Element);
1220       end Write_Node;
1221
1222    --  Start of processing for Write
1223
1224    begin
1225       Write_Nodes (Stream, Container);
1226    end Write;
1227
1228    procedure Write
1229      (Stream : not null access Root_Stream_Type'Class;
1230       Item   : Cursor)
1231    is
1232    begin
1233       raise Program_Error with "attempt to stream map cursor";
1234    end Write;
1235
1236    procedure Write
1237      (Stream : not null access Root_Stream_Type'Class;
1238       Item   : Reference_Type)
1239    is
1240    begin
1241       raise Program_Error with "attempt to stream reference";
1242    end Write;
1243
1244    procedure Write
1245      (Stream : not null access Root_Stream_Type'Class;
1246       Item   : Constant_Reference_Type)
1247    is
1248    begin
1249       raise Program_Error with "attempt to stream reference";
1250    end Write;
1251
1252 end Ada.Containers.Bounded_Hashed_Maps;