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