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