gcc/ada/a-cihama.adb

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