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          Node : Node_Access := new Node_Type; --  Ada 2005 aggregate possible?
 442
 443       begin
 444          Node.Key := Key;
 445          Node.Next := Next;
 446
 447          return Node;
 448
 449       exception
 450          when others =>
 451             Free (Node);
 452             raise;
 453       end New_Node;
 454
 455       HT : Hash_Table_Type renames Container.HT;
 456
 457    --  Start of processing for Insert
 458
 459    begin
 460       if HT_Ops.Capacity (HT) = 0 then
 461          HT_Ops.Reserve_Capacity (HT, 1);
 462       end if;
 463
 464       Local_Insert (HT, Key, Position.Node, Inserted);
 465
 466       if Inserted
 467         and then HT.Length > HT_Ops.Capacity (HT)
 468       then
 469          HT_Ops.Reserve_Capacity (HT, HT.Length);
 470       end if;
 471
 472       Position.Container := Container'Unchecked_Access;
 473    end Insert;
 474
 475    procedure Insert
 476      (Container : in out Map;
 477       Key       : Key_Type;
 478       New_Item  : Element_Type;
 479       Position  : out Cursor;
 480       Inserted  : out Boolean)
 481    is
 482       function New_Node (Next : Node_Access) return Node_Access;
 483       pragma Inline (New_Node);
 484
 485       procedure Local_Insert is
 486         new Key_Ops.Generic_Conditional_Insert (New_Node);
 487
 488       --------------
 489       -- New_Node --
 490       --------------
 491
 492       function New_Node (Next : Node_Access) return Node_Access is
 493          Node : constant Node_Access := new Node_Type'(Key, New_Item, Next);
 494       begin
 495          return Node;
 496       end New_Node;
 497
 498       HT : Hash_Table_Type renames Container.HT;
 499
 500    --  Start of processing for Insert
 501
 502    begin
 503       if HT_Ops.Capacity (HT) = 0 then
 504          HT_Ops.Reserve_Capacity (HT, 1);
 505       end if;
 506
 507       Local_Insert (HT, Key, Position.Node, Inserted);
 508
 509       if Inserted
 510         and then HT.Length > HT_Ops.Capacity (HT)
 511       then
 512          HT_Ops.Reserve_Capacity (HT, HT.Length);
 513       end if;
 514
 515       Position.Container := Container'Unchecked_Access;
 516    end Insert;
 517
 518    procedure Insert
 519      (Container : in out Map;
 520       Key       : Key_Type;
 521       New_Item  : Element_Type)
 522    is
 523       Position : Cursor;
 524       Inserted : Boolean;
 525
 526    begin
 527       Insert (Container, Key, New_Item, Position, Inserted);
 528
 529       if not Inserted then
 530          raise Constraint_Error;
 531       end if;
 532    end Insert;
 533
 534    --------------
 535    -- Is_Empty --
 536    --------------
 537
 538    function Is_Empty (Container : Map) return Boolean is
 539    begin
 540       return Container.HT.Length = 0;
 541    end Is_Empty;
 542
 543    -------------
 544    -- Iterate --
 545    -------------
 546
 547    procedure Iterate
 548      (Container : Map;
 549       Process   : not null access procedure (Position : Cursor))
 550    is
 551       procedure Process_Node (Node : Node_Access);
 552       pragma Inline (Process_Node);
 553
 554       procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node);
 555
 556       ------------------
 557       -- Process_Node --
 558       ------------------
 559
 560       procedure Process_Node (Node : Node_Access) is
 561       begin
 562          Process (Cursor'(Container'Unchecked_Access, Node));
 563       end Process_Node;
 564
 565    --  Start of processing for Iterate
 566
 567    begin
 568       Local_Iterate (Container.HT);
 569    end Iterate;
 570
 571    ---------
 572    -- Key --
 573    ---------
 574
 575    function Key (Position : Cursor) return Key_Type is
 576    begin
 577       pragma Assert (Vet (Position), "bad cursor in function Key");
 578
 579       if Position.Node = null then
 580          raise Constraint_Error;
 581       end if;
 582
 583       return Position.Node.Key;
 584    end Key;
 585
 586    ------------
 587    -- Length --
 588    ------------
 589
 590    function Length (Container : Map) return Count_Type is
 591    begin
 592       return Container.HT.Length;
 593    end Length;
 594
 595    ----------
 596    -- Move --
 597    ----------
 598
 599    procedure Move
 600      (Target : in out Map;
 601       Source : in out Map)
 602    is
 603    begin
 604       HT_Ops.Move (Target => Target.HT, Source => Source.HT);
 605    end Move;
 606
 607    ----------
 608    -- Next --
 609    ----------
 610
 611    function Next (Node : Node_Access) return Node_Access is
 612    begin
 613       return Node.Next;
 614    end Next;
 615
 616    function Next (Position : Cursor) return Cursor is
 617    begin
 618       pragma Assert (Vet (Position), "bad cursor in function Next");
 619
 620       if Position.Node = null then
 621          return No_Element;
 622       end if;
 623
 624       declare
 625          HT   : Hash_Table_Type renames Position.Container.HT;
 626          Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
 627       begin
 628          if Node = null then
 629             return No_Element;
 630          end if;
 631
 632          return Cursor'(Position.Container, Node);
 633       end;
 634    end Next;
 635
 636    procedure Next (Position : in out Cursor) is
 637    begin
 638       Position := Next (Position);
 639    end Next;
 640
 641    -------------------
 642    -- Query_Element --
 643    -------------------
 644
 645    procedure Query_Element
 646      (Position : Cursor;
 647       Process  : not null access
 648                    procedure (Key : Key_Type; Element : Element_Type))
 649    is
 650    begin
 651       pragma Assert (Vet (Position), "bad cursor in Query_Element");
 652
 653       if Position.Node = null then
 654          raise Constraint_Error;
 655       end if;
 656
 657       declare
 658          M  : Map renames Position.Container.all;
 659          HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
 660
 661          B : Natural renames HT.Busy;
 662          L : Natural renames HT.Lock;
 663
 664       begin
 665          B := B + 1;
 666          L := L + 1;
 667
 668          declare
 669             K : Key_Type renames Position.Node.Key;
 670             E : Element_Type renames Position.Node.Element;
 671
 672          begin
 673             Process (K, E);
 674          exception
 675             when others =>
 676                L := L - 1;
 677                B := B - 1;
 678                raise;
 679          end;
 680
 681          L := L - 1;
 682          B := B - 1;
 683       end;
 684    end Query_Element;
 685
 686    ----------
 687    -- Read --
 688    ----------
 689
 690    procedure Read
 691      (Stream    : access Root_Stream_Type'Class;
 692       Container : out Map)
 693    is
 694    begin
 695       Read_Nodes (Stream, Container.HT);
 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 (Position : Cursor; By : Element_Type) is
 747    begin
 748       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
 749
 750       if Position.Node = null then
 751          raise Constraint_Error;
 752       end if;
 753
 754       if Position.Container.HT.Lock > 0 then
 755          raise Program_Error;
 756       end if;
 757
 758       Position.Node.Element := By;
 759    end Replace_Element;
 760
 761    ----------------------
 762    -- Reserve_Capacity --
 763    ----------------------
 764
 765    procedure Reserve_Capacity
 766      (Container : in out Map;
 767       Capacity  : Count_Type)
 768    is
 769    begin
 770       HT_Ops.Reserve_Capacity (Container.HT, Capacity);
 771    end Reserve_Capacity;
 772
 773    --------------
 774    -- Set_Next --
 775    --------------
 776
 777    procedure Set_Next (Node : Node_Access; Next : Node_Access) is
 778    begin
 779       Node.Next := Next;
 780    end Set_Next;
 781
 782    --------------------
 783    -- Update_Element --
 784    --------------------
 785
 786    procedure Update_Element
 787      (Position : Cursor;
 788       Process  : not null access procedure (Key     : Key_Type;
 789                                             Element : in out Element_Type))
 790    is
 791    begin
 792       pragma Assert (Vet (Position), "bad cursor in Update_Element");
 793
 794       if Position.Node = null then
 795          raise Constraint_Error;
 796       end if;
 797
 798       declare
 799          M  : Map renames Position.Container.all;
 800          HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
 801
 802          B : Natural renames HT.Busy;
 803          L : Natural renames HT.Lock;
 804
 805       begin
 806          B := B + 1;
 807          L := L + 1;
 808
 809          declare
 810             K : Key_Type renames Position.Node.Key;
 811             E : Element_Type renames Position.Node.Element;
 812
 813          begin
 814             Process (K, E);
 815          exception
 816             when others =>
 817                L := L - 1;
 818                B := B - 1;
 819                raise;
 820          end;
 821
 822          L := L - 1;
 823          B := B - 1;
 824       end;
 825    end Update_Element;
 826
 827    ---------
 828    -- Vet --
 829    ---------
 830
 831    function Vet (Position : Cursor) return Boolean is
 832    begin
 833       if Position.Node = null then
 834          return Position.Container = null;
 835       end if;
 836
 837       if Position.Container = null then
 838          return False;
 839       end if;
 840
 841       if Position.Node.Next = Position.Node then
 842          return False;
 843       end if;
 844
 845       declare
 846          HT : Hash_Table_Type renames Position.Container.HT;
 847          X  : Node_Access;
 848
 849       begin
 850          if HT.Length = 0 then
 851             return False;
 852          end if;
 853
 854          if HT.Buckets = null
 855            or else HT.Buckets'Length = 0
 856          then
 857             return False;
 858          end if;
 859
 860          X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key));
 861
 862          for J in 1 .. HT.Length loop
 863             if X = Position.Node then
 864                return True;
 865             end if;
 866
 867             if X = null then
 868                return False;
 869             end if;
 870
 871             if X = X.Next then  --  to prevent endless loop
 872                return False;
 873             end if;
 874
 875             X := X.Next;
 876          end loop;
 877
 878          return False;
 879       end;
 880    end Vet;
 881
 882    -----------
 883    -- Write --
 884    -----------
 885
 886    procedure Write
 887      (Stream    : access Root_Stream_Type'Class;
 888       Container : Map)
 889    is
 890    begin
 891       Write_Nodes (Stream, Container.HT);
 892    end Write;
 893
 894    ----------------
 895    -- Write_Node --
 896    ----------------
 897
 898    procedure Write_Node
 899      (Stream : access Root_Stream_Type'Class;
 900       Node   : Node_Access)
 901    is
 902    begin
 903       Key_Type'Write (Stream, Node.Key);
 904       Element_Type'Write (Stream, Node.Element);
 905    end Write_Node;
 906
 907 end Ada.Containers.Hashed_Maps;