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