gcc/ada/a-cohama.adb

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