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-2010, 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 with System;  use type System.Address;
  38
  39 package body Ada.Containers.Bounded_Hashed_Maps is
  40
  41    -----------------------
  42    -- Local Subprograms --
  43    -----------------------
  44
  45    function Equivalent_Key_Node
  46      (Key  : Key_Type;
  47       Node : Node_Type) return Boolean;
  48    pragma Inline (Equivalent_Key_Node);
  49
  50    function Hash_Node (Node : Node_Type) return Hash_Type;
  51    pragma Inline (Hash_Node);
  52
  53    function Next (Node : Node_Type) return Count_Type;
  54    pragma Inline (Next);
  55
  56    procedure Set_Next (Node : in out Node_Type; Next : Count_Type);
  57    pragma Inline (Set_Next);
  58
  59    function Vet (Position : Cursor) return Boolean;
  60
  61    --------------------------
  62    -- Local Instantiations --
  63    --------------------------
  64
  65    package HT_Ops is new Hash_Tables.Generic_Bounded_Operations
  66      (HT_Types  => HT_Types,
  67       Hash_Node => Hash_Node,
  68       Next      => Next,
  69       Set_Next  => Set_Next);
  70
  71    package Key_Ops is new Hash_Tables.Generic_Bounded_Keys
  72      (HT_Types        => HT_Types,
  73       Next            => Next,
  74       Set_Next        => Set_Next,
  75       Key_Type        => Key_Type,
  76       Hash            => Hash,
  77       Equivalent_Keys => Equivalent_Key_Node);
  78
  79    ---------
  80    -- "=" --
  81    ---------
  82
  83    function "=" (Left, Right : Map) return Boolean is
  84       function Find_Equal_Key
  85         (R_HT   : Hash_Table_Type'Class;
  86          L_Node : Node_Type) return Boolean;
  87
  88       function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key);
  89
  90       --------------------
  91       -- Find_Equal_Key --
  92       --------------------
  93
  94       function Find_Equal_Key
  95         (R_HT   : Hash_Table_Type'Class;
  96          L_Node : Node_Type) return Boolean
  97       is
  98          R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key);
  99          R_Node  : Count_Type := R_HT.Buckets (R_Index);
 100
 101       begin
 102          while R_Node /= 0 loop
 103             if Equivalent_Keys (L_Node.Key, R_HT.Nodes (R_Node).Key) then
 104                return L_Node.Element = R_HT.Nodes (R_Node).Element;
 105             end if;
 106
 107             R_Node := R_HT.Nodes (R_Node).Next;
 108          end loop;
 109
 110          return False;
 111       end Find_Equal_Key;
 112
 113    --  Start of processing for "="
 114
 115    begin
 116       return Is_Equal (Left, Right);
 117    end "=";
 118
 119    ------------
 120    -- Assign --
 121    ------------
 122
 123    procedure Assign (Target : in out Map; Source : Map) is
 124       procedure Insert_Element (Source_Node : Count_Type);
 125
 126       procedure Insert_Elements is
 127          new HT_Ops.Generic_Iteration (Insert_Element);
 128
 129       --------------------
 130       -- Insert_Element --
 131       --------------------
 132
 133       procedure Insert_Element (Source_Node : Count_Type) is
 134          N : Node_Type renames Source.Nodes (Source_Node);
 135          C : Cursor;
 136          B : Boolean;
 137
 138       begin
 139          Insert (Target, N.Key, N.Element, C, B);
 140          pragma Assert (B);
 141       end Insert_Element;
 142
 143    --  Start of processing for Assign
 144
 145    begin
 146       if Target'Address = Source'Address then
 147          return;
 148       end if;
 149
 150       if Target.Capacity < Source.Length then
 151          raise Capacity_Error
 152            with "Target capacity is less than Source length";
 153       end if;
 154
 155       HT_Ops.Clear (Target);
 156       Insert_Elements (Source);
 157    end Assign;
 158
 159    --------------
 160    -- Capacity --
 161    --------------
 162
 163    function Capacity (Container : Map) return Count_Type is
 164    begin
 165       return Container.Capacity;
 166    end Capacity;
 167
 168    -----------
 169    -- Clear --
 170    -----------
 171
 172    procedure Clear (Container : in out Map) is
 173    begin
 174       HT_Ops.Clear (Container);
 175    end Clear;
 176
 177    --------------
 178    -- Contains --
 179    --------------
 180
 181    function Contains (Container : Map; Key : Key_Type) return Boolean is
 182    begin
 183       return Find (Container, Key) /= No_Element;
 184    end Contains;
 185
 186    ----------
 187    -- Copy --
 188    ----------
 189
 190    function Copy
 191      (Source   : Map;
 192       Capacity : Count_Type := 0;
 193       Modulus  : Hash_Type := 0) return Map
 194    is
 195       C : Count_Type;
 196       M : Hash_Type;
 197
 198    begin
 199       if Capacity = 0 then
 200          C := Source.Length;
 201
 202       elsif Capacity >= Source.Length then
 203          C := Capacity;
 204
 205       else
 206          raise Capacity_Error with "Capacity value too small";
 207       end if;
 208
 209       if Modulus = 0 then
 210          M := Default_Modulus (C);
 211       else
 212          M := Modulus;
 213       end if;
 214
 215       return Target : Map (Capacity => C, Modulus => M) do
 216          Assign (Target => Target, Source => Source);
 217       end return;
 218    end Copy;
 219
 220    ---------------------
 221    -- Default_Modulus --
 222    ---------------------
 223
 224    function Default_Modulus (Capacity : Count_Type) return Hash_Type is
 225    begin
 226       return To_Prime (Capacity);
 227    end Default_Modulus;
 228
 229    ------------
 230    -- Delete --
 231    ------------
 232
 233    procedure Delete (Container : in out Map; Key : Key_Type) is
 234       X : Count_Type;
 235
 236    begin
 237       Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
 238
 239       if X = 0 then
 240          raise Constraint_Error with "attempt to delete key not in map";
 241       end if;
 242
 243       HT_Ops.Free (Container, X);
 244    end Delete;
 245
 246    procedure Delete (Container : in out Map; Position : in out Cursor) is
 247    begin
 248       if Position.Node = 0 then
 249          raise Constraint_Error with
 250            "Position cursor of Delete equals No_Element";
 251       end if;
 252
 253       if Position.Container /= Container'Unrestricted_Access then
 254          raise Program_Error with
 255            "Position cursor of Delete designates wrong map";
 256       end if;
 257
 258       if Container.Busy > 0 then
 259          raise Program_Error with
 260            "Delete attempted to tamper with cursors (map is busy)";
 261       end if;
 262
 263       pragma Assert (Vet (Position), "bad cursor in Delete");
 264
 265       HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
 266       HT_Ops.Free (Container, Position.Node);
 267
 268       Position := No_Element;
 269    end Delete;
 270
 271    -------------
 272    -- Element --
 273    -------------
 274
 275    function Element (Container : Map; Key : Key_Type) return Element_Type is
 276       Node : constant Count_Type := Key_Ops.Find (Container, Key);
 277
 278    begin
 279       if Node = 0 then
 280          raise Constraint_Error with
 281            "no element available because key not in map";
 282       end if;
 283
 284       return Container.Nodes (Node).Element;
 285    end Element;
 286
 287    function Element (Position : Cursor) return Element_Type is
 288    begin
 289       if Position.Node = 0 then
 290          raise Constraint_Error with
 291            "Position cursor of function Element equals No_Element";
 292       end if;
 293
 294       pragma Assert (Vet (Position), "bad cursor in function Element");
 295
 296       return Position.Container.Nodes (Position.Node).Element;
 297    end Element;
 298
 299    -------------------------
 300    -- Equivalent_Key_Node --
 301    -------------------------
 302
 303    function Equivalent_Key_Node
 304      (Key  : Key_Type;
 305       Node : Node_Type) return Boolean is
 306    begin
 307       return Equivalent_Keys (Key, Node.Key);
 308    end Equivalent_Key_Node;
 309
 310    ---------------------
 311    -- Equivalent_Keys --
 312    ---------------------
 313
 314    function Equivalent_Keys (Left, Right : Cursor)
 315      return Boolean is
 316    begin
 317       if Left.Node = 0 then
 318          raise Constraint_Error with
 319            "Left cursor of Equivalent_Keys equals No_Element";
 320       end if;
 321
 322       if Right.Node = 0 then
 323          raise Constraint_Error with
 324            "Right cursor of Equivalent_Keys equals No_Element";
 325       end if;
 326
 327       pragma Assert (Vet (Left), "Left cursor of Equivalent_Keys is bad");
 328       pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad");
 329
 330       declare
 331          LN : Node_Type renames Left.Container.Nodes (Left.Node);
 332          RN : Node_Type renames Right.Container.Nodes (Right.Node);
 333
 334       begin
 335          return Equivalent_Keys (LN.Key, RN.Key);
 336       end;
 337    end Equivalent_Keys;
 338
 339    function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is
 340    begin
 341       if Left.Node = 0 then
 342          raise Constraint_Error with
 343            "Left cursor of Equivalent_Keys equals No_Element";
 344       end if;
 345
 346       pragma Assert (Vet (Left), "Left cursor in Equivalent_Keys is bad");
 347
 348       declare
 349          LN : Node_Type renames Left.Container.Nodes (Left.Node);
 350
 351       begin
 352          return Equivalent_Keys (LN.Key, Right);
 353       end;
 354    end Equivalent_Keys;
 355
 356    function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is
 357    begin
 358       if Right.Node = 0 then
 359          raise Constraint_Error with
 360            "Right cursor of Equivalent_Keys equals No_Element";
 361       end if;
 362
 363       pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad");
 364
 365       declare
 366          RN : Node_Type renames Right.Container.Nodes (Right.Node);
 367
 368       begin
 369          return Equivalent_Keys (Left, RN.Key);
 370       end;
 371    end Equivalent_Keys;
 372
 373    -------------
 374    -- Exclude --
 375    -------------
 376
 377    procedure Exclude (Container : in out Map; Key : Key_Type) is
 378       X : Count_Type;
 379    begin
 380       Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
 381       HT_Ops.Free (Container, X);
 382    end Exclude;
 383
 384    ----------
 385    -- Find --
 386    ----------
 387
 388    function Find (Container : Map; Key : Key_Type) return Cursor is
 389       Node : constant Count_Type := Key_Ops.Find (Container, Key);
 390
 391    begin
 392       if Node = 0 then
 393          return No_Element;
 394       end if;
 395
 396       return Cursor'(Container'Unrestricted_Access, Node);
 397    end Find;
 398
 399    -----------
 400    -- First --
 401    -----------
 402
 403    function First (Container : Map) return Cursor is
 404       Node : constant Count_Type := HT_Ops.First (Container);
 405
 406    begin
 407       if Node = 0 then
 408          return No_Element;
 409       end if;
 410
 411       return Cursor'(Container'Unrestricted_Access, Node);
 412    end First;
 413
 414    -----------------
 415    -- Has_Element --
 416    -----------------
 417
 418    function Has_Element (Position : Cursor) return Boolean is
 419    begin
 420       pragma Assert (Vet (Position), "bad cursor in Has_Element");
 421       return Position.Node /= 0;
 422    end Has_Element;
 423
 424    ---------------
 425    -- Hash_Node --
 426    ---------------
 427
 428    function Hash_Node (Node : Node_Type) return Hash_Type is
 429    begin
 430       return Hash (Node.Key);
 431    end Hash_Node;
 432
 433    -------------
 434    -- Include --
 435    -------------
 436
 437    procedure Include
 438      (Container : in out Map;
 439       Key       : Key_Type;
 440       New_Item  : Element_Type)
 441    is
 442       Position : Cursor;
 443       Inserted : Boolean;
 444
 445    begin
 446       Insert (Container, Key, New_Item, Position, Inserted);
 447
 448       if not Inserted then
 449          if Container.Lock > 0 then
 450             raise Program_Error with
 451               "Include attempted to tamper with elements (map is locked)";
 452          end if;
 453
 454          declare
 455             N : Node_Type renames Container.Nodes (Position.Node);
 456
 457          begin
 458             N.Key := Key;
 459             N.Element := New_Item;
 460          end;
 461       end if;
 462    end Include;
 463
 464    ------------
 465    -- Insert --
 466    ------------
 467
 468    procedure Insert
 469      (Container : in out Map;
 470       Key       : Key_Type;
 471       Position  : out Cursor;
 472       Inserted  : out Boolean)
 473    is
 474       procedure Assign_Key (Node : in out Node_Type);
 475       pragma Inline (Assign_Key);
 476
 477       function New_Node return Count_Type;
 478       pragma Inline (New_Node);
 479
 480       procedure Local_Insert is
 481         new Key_Ops.Generic_Conditional_Insert (New_Node);
 482
 483       procedure Allocate is
 484          new HT_Ops.Generic_Allocate (Assign_Key);
 485
 486       -----------------
 487       --  Assign_Key --
 488       -----------------
 489
 490       procedure Assign_Key (Node : in out Node_Type) is
 491       begin
 492          Node.Key := Key;
 493          --  Node.Element := New_Item;
 494       end Assign_Key;
 495
 496       --------------
 497       -- New_Node --
 498       --------------
 499
 500       function New_Node return Count_Type is
 501          Result : Count_Type;
 502       begin
 503          Allocate (Container, Result);
 504          return Result;
 505       end New_Node;
 506
 507    --  Start of processing for Insert
 508
 509    begin
 510       --  ???
 511       --  if HT_Ops.Capacity (HT) = 0 then
 512       --     HT_Ops.Reserve_Capacity (HT, 1);
 513       --  end if;
 514
 515       Local_Insert (Container, Key, Position.Node, Inserted);
 516
 517       --  ???
 518       --  if Inserted
 519       --    and then HT.Length > HT_Ops.Capacity (HT)
 520       --  then
 521       --     HT_Ops.Reserve_Capacity (HT, HT.Length);
 522       --  end if;
 523
 524       Position.Container := Container'Unchecked_Access;
 525    end Insert;
 526
 527    procedure Insert
 528      (Container : in out Map;
 529       Key       : Key_Type;
 530       New_Item  : Element_Type;
 531       Position  : out Cursor;
 532       Inserted  : out Boolean)
 533    is
 534       procedure Assign_Key (Node : in out Node_Type);
 535       pragma Inline (Assign_Key);
 536
 537       function New_Node return Count_Type;
 538       pragma Inline (New_Node);
 539
 540       procedure Local_Insert is
 541         new Key_Ops.Generic_Conditional_Insert (New_Node);
 542
 543       procedure Allocate is
 544          new HT_Ops.Generic_Allocate (Assign_Key);
 545
 546       -----------------
 547       --  Assign_Key --
 548       -----------------
 549
 550       procedure Assign_Key (Node : in out Node_Type) is
 551       begin
 552          Node.Key := Key;
 553          Node.Element := New_Item;
 554       end Assign_Key;
 555
 556       --------------
 557       -- New_Node --
 558       --------------
 559
 560       function New_Node return Count_Type is
 561          Result : Count_Type;
 562       begin
 563          Allocate (Container, Result);
 564          return Result;
 565       end New_Node;
 566
 567    --  Start of processing for Insert
 568
 569    begin
 570       --  ??
 571       --  if HT_Ops.Capacity (HT) = 0 then
 572       --     HT_Ops.Reserve_Capacity (HT, 1);
 573       --  end if;
 574
 575       Local_Insert (Container, Key, Position.Node, Inserted);
 576
 577       --  ???
 578       --  if Inserted
 579       --    and then HT.Length > HT_Ops.Capacity (HT)
 580       --  then
 581       --     HT_Ops.Reserve_Capacity (HT, HT.Length);
 582       --  end if;
 583
 584       Position.Container := Container'Unchecked_Access;
 585    end Insert;
 586
 587    procedure Insert
 588      (Container : in out Map;
 589       Key       : Key_Type;
 590       New_Item  : Element_Type)
 591    is
 592       Position : Cursor;
 593       pragma Unreferenced (Position);
 594
 595       Inserted : Boolean;
 596
 597    begin
 598       Insert (Container, Key, New_Item, Position, Inserted);
 599
 600       if not Inserted then
 601          raise Constraint_Error with
 602            "attempt to insert key already in map";
 603       end if;
 604    end Insert;
 605
 606    --------------
 607    -- Is_Empty --
 608    --------------
 609
 610    function Is_Empty (Container : Map) return Boolean is
 611    begin
 612       return Container.Length = 0;
 613    end Is_Empty;
 614
 615    -------------
 616    -- Iterate --
 617    -------------
 618
 619    procedure Iterate
 620      (Container : Map;
 621       Process   : not null access procedure (Position : Cursor))
 622    is
 623       procedure Process_Node (Node : Count_Type);
 624       pragma Inline (Process_Node);
 625
 626       procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node);
 627
 628       ------------------
 629       -- Process_Node --
 630       ------------------
 631
 632       procedure Process_Node (Node : Count_Type) is
 633       begin
 634          Process (Cursor'(Container'Unrestricted_Access, Node));
 635       end Process_Node;
 636
 637       B : Natural renames Container'Unrestricted_Access.Busy;
 638
 639    --  Start of processing for Iterate
 640
 641    begin
 642       B := B + 1;
 643
 644       begin
 645          Local_Iterate (Container);
 646       exception
 647          when others =>
 648             B := B - 1;
 649             raise;
 650       end;
 651
 652       B := B - 1;
 653    end Iterate;
 654
 655    ---------
 656    -- Key --
 657    ---------
 658
 659    function Key (Position : Cursor) return Key_Type is
 660    begin
 661       if Position.Node = 0 then
 662          raise Constraint_Error with
 663            "Position cursor of function Key equals No_Element";
 664       end if;
 665
 666       pragma Assert (Vet (Position), "bad cursor in function Key");
 667
 668       return Position.Container.Nodes (Position.Node).Key;
 669    end Key;
 670
 671    ------------
 672    -- Length --
 673    ------------
 674
 675    function Length (Container : Map) return Count_Type is
 676    begin
 677       return Container.Length;
 678    end Length;
 679
 680    ----------
 681    -- Move --
 682    ----------
 683
 684    procedure Move
 685      (Target : in out Map;
 686       Source : in out Map)
 687    is
 688    begin
 689       if Target'Address = Source'Address then
 690          return;
 691       end if;
 692
 693       if Source.Busy > 0 then
 694          raise Program_Error with
 695            "attempt to tamper with cursors (container is busy)";
 696       end if;
 697
 698       Assign (Target => Target, Source => Source);
 699    end Move;
 700
 701    ----------
 702    -- Next --
 703    ----------
 704
 705    function Next (Node : Node_Type) return Count_Type is
 706    begin
 707       return Node.Next;
 708    end Next;
 709
 710    function Next (Position : Cursor) return Cursor is
 711    begin
 712       if Position.Node = 0 then
 713          return No_Element;
 714       end if;
 715
 716       pragma Assert (Vet (Position), "bad cursor in function Next");
 717
 718       declare
 719          M    : Map renames Position.Container.all;
 720          Node : constant Count_Type := HT_Ops.Next (M, Position.Node);
 721
 722       begin
 723          if Node = 0 then
 724             return No_Element;
 725          end if;
 726
 727          return Cursor'(Position.Container, Node);
 728       end;
 729    end Next;
 730
 731    procedure Next (Position : in out Cursor) is
 732    begin
 733       Position := Next (Position);
 734    end Next;
 735
 736    -------------------
 737    -- Query_Element --
 738    -------------------
 739
 740    procedure Query_Element
 741      (Position : Cursor;
 742       Process  : not null access
 743                    procedure (Key : Key_Type; Element : Element_Type))
 744    is
 745    begin
 746       if Position.Node = 0 then
 747          raise Constraint_Error with
 748            "Position cursor of Query_Element equals No_Element";
 749       end if;
 750
 751       pragma Assert (Vet (Position), "bad cursor in Query_Element");
 752
 753       declare
 754          M : Map renames Position.Container.all;
 755          N : Node_Type renames M.Nodes (Position.Node);
 756          B : Natural renames M.Busy;
 757          L : Natural renames M.Lock;
 758
 759       begin
 760          B := B + 1;
 761          L := L + 1;
 762
 763          declare
 764
 765          begin
 766             Process (N.Key, N.Element);
 767          exception
 768             when others =>
 769                L := L - 1;
 770                B := B - 1;
 771                raise;
 772          end;
 773
 774          L := L - 1;
 775          B := B - 1;
 776       end;
 777    end Query_Element;
 778
 779    ----------
 780    -- Read --
 781    ----------
 782
 783    procedure Read
 784      (Stream    : not null access Root_Stream_Type'Class;
 785       Container : out Map)
 786    is
 787       function Read_Node
 788         (Stream : not null access Root_Stream_Type'Class) return Count_Type;
 789       --  pragma Inline (Read_Node);  ???
 790
 791       procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node);
 792
 793       ---------------
 794       -- Read_Node --
 795       ---------------
 796
 797       function Read_Node
 798         (Stream : not null access Root_Stream_Type'Class) return Count_Type
 799       is
 800          procedure Read_Element (Node : in out Node_Type);
 801          --  pragma Inline (Read_Element);  ???
 802
 803          procedure Allocate is
 804             new HT_Ops.Generic_Allocate (Read_Element);
 805
 806          procedure Read_Element (Node : in out Node_Type) is
 807          begin
 808             Key_Type'Read (Stream, Node.Key);
 809             Element_Type'Read (Stream, Node.Element);
 810          end Read_Element;
 811
 812          Node : Count_Type;
 813
 814       --  Start of processing for Read_Node
 815
 816       begin
 817          Allocate (Container, Node);
 818          return Node;
 819       end Read_Node;
 820
 821    --  Start of processing for Read
 822
 823    begin
 824       Read_Nodes (Stream, Container);
 825    end Read;
 826
 827    procedure Read
 828      (Stream : not null access Root_Stream_Type'Class;
 829       Item   : out Cursor)
 830    is
 831    begin
 832       raise Program_Error with "attempt to stream map cursor";
 833    end Read;
 834
 835    -------------
 836    -- Replace --
 837    -------------
 838
 839    procedure Replace
 840      (Container : in out Map;
 841       Key       : Key_Type;
 842       New_Item  : Element_Type)
 843    is
 844       Node : constant Count_Type := Key_Ops.Find (Container, Key);
 845
 846    begin
 847       if Node = 0 then
 848          raise Constraint_Error with
 849            "attempt to replace key not in map";
 850       end if;
 851
 852       if Container.Lock > 0 then
 853          raise Program_Error with
 854            "Replace attempted to tamper with elements (map is locked)";
 855       end if;
 856
 857       declare
 858          N : Node_Type renames Container.Nodes (Node);
 859
 860       begin
 861          N.Key := Key;
 862          N.Element := New_Item;
 863       end;
 864    end Replace;
 865
 866    ---------------------
 867    -- Replace_Element --
 868    ---------------------
 869
 870    procedure Replace_Element
 871      (Container : in out Map;
 872       Position  : Cursor;
 873       New_Item  : Element_Type)
 874    is
 875    begin
 876       if Position.Node = 0 then
 877          raise Constraint_Error with
 878            "Position cursor of Replace_Element equals No_Element";
 879       end if;
 880
 881       if Position.Container /= Container'Unrestricted_Access then
 882          raise Program_Error with
 883            "Position cursor of Replace_Element designates wrong map";
 884       end if;
 885
 886       if Position.Container.Lock > 0 then
 887          raise Program_Error with
 888            "Replace_Element attempted to tamper with elements (map is locked)";
 889       end if;
 890
 891       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
 892
 893       Container.Nodes (Position.Node).Element := New_Item;
 894    end Replace_Element;
 895
 896    ----------------------
 897    -- Reserve_Capacity --
 898    ----------------------
 899
 900    procedure Reserve_Capacity
 901      (Container : in out Map;
 902       Capacity  : Count_Type)
 903    is
 904    begin
 905       if Capacity > Container.Capacity then
 906          raise Capacity_Error with "requested capacity is too large";
 907       end if;
 908    end Reserve_Capacity;
 909
 910    --------------
 911    -- Set_Next --
 912    --------------
 913
 914    procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is
 915    begin
 916       Node.Next := Next;
 917    end Set_Next;
 918
 919    --------------------
 920    -- Update_Element --
 921    --------------------
 922
 923    procedure Update_Element
 924      (Container : in out Map;
 925       Position  : Cursor;
 926       Process   : not null access procedure (Key     : Key_Type;
 927                                              Element : in out Element_Type))
 928    is
 929    begin
 930       if Position.Node = 0 then
 931          raise Constraint_Error with
 932            "Position cursor of Update_Element equals No_Element";
 933       end if;
 934
 935       if Position.Container /= Container'Unrestricted_Access then
 936          raise Program_Error with
 937            "Position cursor of Update_Element designates wrong map";
 938       end if;
 939
 940       pragma Assert (Vet (Position), "bad cursor in Update_Element");
 941
 942       declare
 943          N : Node_Type renames Container.Nodes (Position.Node);
 944          B : Natural renames Container.Busy;
 945          L : Natural renames Container.Lock;
 946
 947       begin
 948          B := B + 1;
 949          L := L + 1;
 950
 951          begin
 952             Process (N.Key, N.Element);
 953          exception
 954             when others =>
 955                L := L - 1;
 956                B := B - 1;
 957                raise;
 958          end;
 959
 960          L := L - 1;
 961          B := B - 1;
 962       end;
 963    end Update_Element;
 964
 965    ---------
 966    -- Vet --
 967    ---------
 968
 969    function Vet (Position : Cursor) return Boolean is
 970    begin
 971       if Position.Node = 0 then
 972          return Position.Container = null;
 973       end if;
 974
 975       if Position.Container = null then
 976          return False;
 977       end if;
 978
 979       declare
 980          M : Map renames Position.Container.all;
 981          X : Count_Type;
 982
 983       begin
 984          if M.Length = 0 then
 985             return False;
 986          end if;
 987
 988          if M.Capacity = 0 then
 989             return False;
 990          end if;
 991
 992          if M.Buckets'Length = 0 then
 993             return False;
 994          end if;
 995
 996          if Position.Node > M.Capacity then
 997             return False;
 998          end if;
 999
1000          if M.Nodes (Position.Node).Next = Position.Node then
1001             return False;
1002          end if;
1003
1004          X := M.Buckets (Key_Ops.Index (M, M.Nodes (Position.Node).Key));
1005
1006          for J in 1 .. M.Length loop
1007             if X = Position.Node then
1008                return True;
1009             end if;
1010
1011             if X = 0 then
1012                return False;
1013             end if;
1014
1015             if X = M.Nodes (X).Next then  --  to prevent unnecessary looping
1016                return False;
1017             end if;
1018
1019             X := M.Nodes (X).Next;
1020          end loop;
1021
1022          return False;
1023       end;
1024    end Vet;
1025
1026    -----------
1027    -- Write --
1028    -----------
1029
1030    procedure Write
1031      (Stream    : not null access Root_Stream_Type'Class;
1032       Container : Map)
1033    is
1034       procedure Write_Node
1035         (Stream : not null access Root_Stream_Type'Class;
1036          Node   : Node_Type);
1037       pragma Inline (Write_Node);
1038
1039       procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
1040
1041       ----------------
1042       -- Write_Node --
1043       ----------------
1044
1045       procedure Write_Node
1046         (Stream : not null access Root_Stream_Type'Class;
1047          Node   : Node_Type)
1048       is
1049       begin
1050          Key_Type'Write (Stream, Node.Key);
1051          Element_Type'Write (Stream, Node.Element);
1052       end Write_Node;
1053
1054    --  Start of processing for Write
1055
1056    begin
1057       Write_Nodes (Stream, Container);
1058    end Write;
1059
1060    procedure Write
1061      (Stream : not null access Root_Stream_Type'Class;
1062       Item   : Cursor)
1063    is
1064    begin
1065       raise Program_Error with "attempt to stream map cursor";
1066    end Write;
1067
1068 end Ada.Containers.Bounded_Hashed_Maps;