gcc/ada/a-cihama.adb

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