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