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       return Position.Node.Element.all;
 241    end Element;
 242
 243    -------------------------
 244    -- Equivalent_Key_Node --
 245    -------------------------
 246
 247    function Equivalent_Key_Node
 248      (Key  : Key_Type;
 249       Node : Node_Access) return Boolean
 250    is
 251    begin
 252       return Equivalent_Keys (Key, Node.Key.all);
 253    end Equivalent_Key_Node;
 254
 255    ---------------------
 256    -- Equivalent_Keys --
 257    ---------------------
 258
 259    function Equivalent_Keys (Left, Right : Cursor) return Boolean is
 260    begin
 261       pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
 262       pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
 263
 264       if Left.Node = null
 265         or else Right.Node = null
 266       then
 267          raise Constraint_Error;
 268       end if;
 269
 270       return Equivalent_Keys (Left.Node.Key.all, Right.Node.Key.all);
 271    end Equivalent_Keys;
 272
 273    function Equivalent_Keys
 274      (Left  : Cursor;
 275       Right : Key_Type) return Boolean
 276    is
 277    begin
 278       pragma Assert (Vet (Left), "bad Left cursor in Equivalent_Keys");
 279
 280       if Left.Node = null then
 281          raise Constraint_Error;
 282       end if;
 283
 284       return Equivalent_Keys (Left.Node.Key.all, Right);
 285    end Equivalent_Keys;
 286
 287    function Equivalent_Keys
 288      (Left  : Key_Type;
 289       Right : Cursor) return Boolean
 290    is
 291    begin
 292       pragma Assert (Vet (Right), "bad Right cursor in Equivalent_Keys");
 293
 294       if Right.Node = null then
 295          raise Constraint_Error;
 296       end if;
 297
 298       return Equivalent_Keys (Left, Right.Node.Key.all);
 299    end Equivalent_Keys;
 300
 301    -------------
 302    -- Exclude --
 303    -------------
 304
 305    procedure Exclude (Container : in out Map; Key : Key_Type) is
 306       X : Node_Access;
 307    begin
 308       Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
 309       Free (X);
 310    end Exclude;
 311
 312    --------------
 313    -- Finalize --
 314    --------------
 315
 316    procedure Finalize (Container : in out Map) is
 317    begin
 318       HT_Ops.Finalize (Container.HT);
 319    end Finalize;
 320
 321    ----------
 322    -- Find --
 323    ----------
 324
 325    function Find (Container : Map; Key : Key_Type) return Cursor is
 326       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
 327
 328    begin
 329       if Node = null then
 330          return No_Element;
 331       end if;
 332
 333       return Cursor'(Container'Unchecked_Access, Node);
 334    end Find;
 335
 336    --------------------
 337    -- Find_Equal_Key --
 338    --------------------
 339
 340    function Find_Equal_Key
 341      (R_HT   : Hash_Table_Type;
 342       L_Node : Node_Access) return Boolean
 343    is
 344       R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key.all);
 345       R_Node  : Node_Access := R_HT.Buckets (R_Index);
 346
 347    begin
 348       while R_Node /= null loop
 349          if Equivalent_Keys (L_Node.Key.all, R_Node.Key.all) then
 350             return L_Node.Element.all = R_Node.Element.all;
 351          end if;
 352
 353          R_Node := R_Node.Next;
 354       end loop;
 355
 356       return False;
 357    end Find_Equal_Key;
 358
 359    -----------
 360    -- First --
 361    -----------
 362
 363    function First (Container : Map) return Cursor is
 364       Node : constant Node_Access := HT_Ops.First (Container.HT);
 365
 366    begin
 367       if Node = null then
 368          return No_Element;
 369       end if;
 370
 371       return Cursor'(Container'Unchecked_Access, Node);
 372    end First;
 373
 374    ----------
 375    -- Free --
 376    ----------
 377
 378    procedure Free (X : in out Node_Access) is
 379       procedure Deallocate is
 380          new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 381    begin
 382       if X = null then
 383          return;
 384       end if;
 385
 386       X.Next := X;  --  detect mischief (in Vet)
 387
 388       begin
 389          Free_Key (X.Key);
 390       exception
 391          when others =>
 392             X.Key := null;
 393
 394             begin
 395                Free_Element (X.Element);
 396             exception
 397                when others =>
 398                   X.Element := null;
 399             end;
 400
 401             Deallocate (X);
 402             raise;
 403       end;
 404
 405       begin
 406          Free_Element (X.Element);
 407       exception
 408          when others =>
 409             X.Element := null;
 410
 411             Deallocate (X);
 412             raise;
 413       end;
 414
 415       Deallocate (X);
 416    end Free;
 417
 418    -----------------
 419    -- Has_Element --
 420    -----------------
 421
 422    function Has_Element (Position : Cursor) return Boolean is
 423    begin
 424       pragma Assert (Vet (Position), "bad cursor in Has_Element");
 425       return Position.Node /= null;
 426    end Has_Element;
 427
 428    ---------------
 429    -- Hash_Node --
 430    ---------------
 431
 432    function Hash_Node (Node : Node_Access) return Hash_Type is
 433    begin
 434       return Hash (Node.Key.all);
 435    end Hash_Node;
 436
 437    -------------
 438    -- Include --
 439    -------------
 440
 441    procedure Include
 442      (Container : in out Map;
 443       Key       : Key_Type;
 444       New_Item  : Element_Type)
 445    is
 446       Position : Cursor;
 447       Inserted : Boolean;
 448
 449       K : Key_Access;
 450       E : Element_Access;
 451
 452    begin
 453       Insert (Container, Key, New_Item, Position, Inserted);
 454
 455       if not Inserted then
 456          if Container.HT.Lock > 0 then
 457             raise Program_Error;
 458          end if;
 459
 460          K := Position.Node.Key;
 461          E := Position.Node.Element;
 462
 463          Position.Node.Key := new Key_Type'(Key);
 464
 465          begin
 466             Position.Node.Element := new Element_Type'(New_Item);
 467          exception
 468             when others =>
 469                Free_Key (K);
 470                raise;
 471          end;
 472
 473          Free_Key (K);
 474          Free_Element (E);
 475       end if;
 476    end Include;
 477
 478    ------------
 479    -- Insert --
 480    ------------
 481
 482    procedure Insert
 483      (Container : in out Map;
 484       Key       : Key_Type;
 485       New_Item  : Element_Type;
 486       Position  : out Cursor;
 487       Inserted  : out Boolean)
 488    is
 489       function New_Node (Next : Node_Access) return Node_Access;
 490
 491       procedure Local_Insert is
 492         new Key_Ops.Generic_Conditional_Insert (New_Node);
 493
 494       --------------
 495       -- New_Node --
 496       --------------
 497
 498       function New_Node (Next : Node_Access) return Node_Access is
 499          K  : Key_Access := new Key_Type'(Key);
 500          E  : Element_Access;
 501
 502       begin
 503          E := new Element_Type'(New_Item);
 504          return new Node_Type'(K, E, Next);
 505       exception
 506          when others =>
 507             Free_Key (K);
 508             Free_Element (E);
 509             raise;
 510       end New_Node;
 511
 512       HT : Hash_Table_Type renames Container.HT;
 513
 514    --  Start of processing for Insert
 515
 516    begin
 517       if HT_Ops.Capacity (HT) = 0 then
 518          HT_Ops.Reserve_Capacity (HT, 1);
 519       end if;
 520
 521       Local_Insert (HT, Key, Position.Node, Inserted);
 522
 523       if Inserted
 524         and then HT.Length > HT_Ops.Capacity (HT)
 525       then
 526          HT_Ops.Reserve_Capacity (HT, HT.Length);
 527       end if;
 528
 529       Position.Container := Container'Unchecked_Access;
 530    end Insert;
 531
 532    procedure Insert
 533      (Container : in out Map;
 534       Key       : Key_Type;
 535       New_Item  : Element_Type)
 536    is
 537       Position : Cursor;
 538       Inserted : Boolean;
 539
 540    begin
 541       Insert (Container, Key, New_Item, Position, Inserted);
 542
 543       if not Inserted then
 544          raise Constraint_Error;
 545       end if;
 546    end Insert;
 547
 548    --------------
 549    -- Is_Empty --
 550    --------------
 551
 552    function Is_Empty (Container : Map) return Boolean is
 553    begin
 554       return Container.HT.Length = 0;
 555    end Is_Empty;
 556
 557    -------------
 558    -- Iterate --
 559    -------------
 560
 561    procedure Iterate
 562      (Container : Map;
 563       Process   : not null access procedure (Position : Cursor))
 564    is
 565       procedure Process_Node (Node : Node_Access);
 566       pragma Inline (Process_Node);
 567
 568       procedure Iterate is
 569          new HT_Ops.Generic_Iteration (Process_Node);
 570
 571       ------------------
 572       -- Process_Node --
 573       ------------------
 574
 575       procedure Process_Node (Node : Node_Access) is
 576       begin
 577          Process (Cursor'(Container'Unchecked_Access, Node));
 578       end Process_Node;
 579
 580    --  Start of processing Iterate
 581
 582    begin
 583       Iterate (Container.HT);
 584    end Iterate;
 585
 586    ---------
 587    -- Key --
 588    ---------
 589
 590    function Key (Position : Cursor) return Key_Type is
 591    begin
 592       pragma Assert (Vet (Position), "bad cursor in function Key");
 593
 594       if Position.Node = null then
 595          raise Constraint_Error;
 596       end if;
 597
 598       return Position.Node.Key.all;
 599    end Key;
 600
 601    ------------
 602    -- Length --
 603    ------------
 604
 605    function Length (Container : Map) return Count_Type is
 606    begin
 607       return Container.HT.Length;
 608    end Length;
 609
 610    ----------
 611    -- Move --
 612    ----------
 613
 614    procedure Move
 615      (Target : in out Map;
 616       Source : in out Map)
 617    is
 618    begin
 619       HT_Ops.Move (Target => Target.HT, Source => Source.HT);
 620    end Move;
 621
 622    ----------
 623    -- Next --
 624    ----------
 625
 626    function Next (Node : Node_Access) return Node_Access is
 627    begin
 628       return Node.Next;
 629    end Next;
 630
 631    procedure Next (Position : in out Cursor) is
 632    begin
 633       Position := Next (Position);
 634    end Next;
 635
 636    function Next (Position : Cursor) return Cursor is
 637    begin
 638       pragma Assert (Vet (Position), "bad cursor in function Next");
 639
 640       if Position.Node = null then
 641          return No_Element;
 642       end if;
 643
 644       declare
 645          HT   : Hash_Table_Type renames Position.Container.HT;
 646          Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
 647
 648       begin
 649          if Node = null then
 650             return No_Element;
 651          end if;
 652
 653          return Cursor'(Position.Container, Node);
 654       end;
 655    end Next;
 656
 657    -------------------
 658    -- Query_Element --
 659    -------------------
 660
 661    procedure Query_Element
 662      (Position : Cursor;
 663       Process  : not null access procedure (Key     : Key_Type;
 664                                             Element : Element_Type))
 665    is
 666    begin
 667       pragma Assert (Vet (Position), "bad cursor in Query_Element");
 668
 669       if Position.Node = null then
 670          raise Constraint_Error;
 671       end if;
 672
 673       declare
 674          M  : Map renames Position.Container.all;
 675          HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
 676
 677          B : Natural renames HT.Busy;
 678          L : Natural renames HT.Lock;
 679
 680       begin
 681          B := B + 1;
 682          L := L + 1;
 683
 684          declare
 685             K : Key_Type renames Position.Node.Key.all;
 686             E : Element_Type renames Position.Node.Element.all;
 687
 688          begin
 689             Process (K, E);
 690          exception
 691             when others =>
 692                L := L - 1;
 693                B := B - 1;
 694                raise;
 695          end;
 696
 697          L := L - 1;
 698          B := B - 1;
 699       end;
 700    end Query_Element;
 701
 702    ----------
 703    -- Read --
 704    ----------
 705
 706    procedure Read_Nodes is new HT_Ops.Generic_Read (Read_Node);
 707
 708    procedure Read
 709      (Stream    : access Root_Stream_Type'Class;
 710       Container : out Map)
 711    is
 712    begin
 713       Read_Nodes (Stream, Container.HT);
 714    end Read;
 715
 716    ---------------
 717    -- Read_Node --
 718    ---------------
 719
 720    function Read_Node
 721      (Stream : access Root_Stream_Type'Class) return Node_Access
 722    is
 723       Node : Node_Access := new Node_Type;
 724
 725    begin
 726       begin
 727          Node.Key := new Key_Type'(Key_Type'Input (Stream));
 728       exception
 729          when others =>
 730             Free (Node);
 731             raise;
 732       end;
 733
 734       begin
 735          Node.Element := new Element_Type'(Element_Type'Input (Stream));
 736       exception
 737          when others =>
 738             Free_Key (Node.Key);
 739             Free (Node);
 740             raise;
 741       end;
 742
 743       return Node;
 744    end Read_Node;
 745
 746    -------------
 747    -- Replace --
 748    -------------
 749
 750    procedure Replace
 751      (Container : in out Map;
 752       Key       : Key_Type;
 753       New_Item  : Element_Type)
 754    is
 755       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
 756
 757       K : Key_Access;
 758       E : Element_Access;
 759
 760    begin
 761       if Node = null then
 762          raise Constraint_Error;
 763       end if;
 764
 765       if Container.HT.Lock > 0 then
 766          raise Program_Error;
 767       end if;
 768
 769       K := Node.Key;
 770       E := Node.Element;
 771
 772       Node.Key := new Key_Type'(Key);
 773
 774       begin
 775          Node.Element := new Element_Type'(New_Item);
 776       exception
 777          when others =>
 778             Free_Key (K);
 779             raise;
 780       end;
 781
 782       Free_Key (K);
 783       Free_Element (E);
 784    end Replace;
 785
 786    ---------------------
 787    -- Replace_Element --
 788    ---------------------
 789
 790    procedure Replace_Element (Position : Cursor; By : Element_Type) is
 791    begin
 792       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
 793
 794       if Position.Node = null then
 795          raise Constraint_Error;
 796       end if;
 797
 798       if Position.Container.HT.Lock > 0 then
 799          raise Program_Error;
 800       end if;
 801
 802       declare
 803          X : Element_Access := Position.Node.Element;
 804
 805       begin
 806          Position.Node.Element := new Element_Type'(By);
 807          Free_Element (X);
 808       end;
 809    end Replace_Element;
 810
 811    ----------------------
 812    -- Reserve_Capacity --
 813    ----------------------
 814
 815    procedure Reserve_Capacity
 816      (Container : in out Map;
 817       Capacity  : Count_Type)
 818    is
 819    begin
 820       HT_Ops.Reserve_Capacity (Container.HT, Capacity);
 821    end Reserve_Capacity;
 822
 823    --------------
 824    -- Set_Next --
 825    --------------
 826
 827    procedure Set_Next (Node : Node_Access; Next : Node_Access) is
 828    begin
 829       Node.Next := Next;
 830    end Set_Next;
 831
 832    --------------------
 833    -- Update_Element --
 834    --------------------
 835
 836    procedure Update_Element
 837      (Position : Cursor;
 838       Process  : not null access procedure (Key     : Key_Type;
 839                                             Element : in out Element_Type))
 840    is
 841    begin
 842       pragma Assert (Vet (Position), "bad cursor in Update_Element");
 843
 844       if Position.Node = null then
 845          raise Constraint_Error;
 846       end if;
 847
 848       declare
 849          M  : Map renames Position.Container.all;
 850          HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
 851
 852          B : Natural renames HT.Busy;
 853          L : Natural renames HT.Lock;
 854
 855       begin
 856          B := B + 1;
 857          L := L + 1;
 858
 859          declare
 860             K : Key_Type renames Position.Node.Key.all;
 861             E : Element_Type renames Position.Node.Element.all;
 862
 863          begin
 864             Process (K, E);
 865          exception
 866             when others =>
 867                L := L - 1;
 868                B := B - 1;
 869                raise;
 870          end;
 871
 872          L := L - 1;
 873          B := B - 1;
 874       end;
 875    end Update_Element;
 876
 877    ---------
 878    -- Vet --
 879    ---------
 880
 881    function Vet (Position : Cursor) return Boolean is
 882    begin
 883       if Position.Node = null then
 884          return Position.Container = null;
 885       end if;
 886
 887       if Position.Container = null then
 888          return False;
 889       end if;
 890
 891       if Position.Node.Next = Position.Node then
 892          return False;
 893       end if;
 894
 895       if Position.Node.Key = null then
 896          return False;
 897       end if;
 898
 899       if Position.Node.Element = null then
 900          return False;
 901       end if;
 902
 903       declare
 904          HT : Hash_Table_Type renames Position.Container.HT;
 905          X  : Node_Access;
 906
 907       begin
 908          if HT.Length = 0 then
 909             return False;
 910          end if;
 911
 912          if HT.Buckets = null
 913            or else HT.Buckets'Length = 0
 914          then
 915             return False;
 916          end if;
 917
 918          X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key.all));
 919
 920          for J in 1 .. HT.Length loop
 921             if X = Position.Node then
 922                return True;
 923             end if;
 924
 925             if X = null then
 926                return False;
 927             end if;
 928
 929             if X = X.Next then -- to prevent endless loop
 930                return False;
 931             end if;
 932
 933             X := X.Next;
 934          end loop;
 935
 936          return False;
 937       end;
 938    end Vet;
 939
 940    -----------
 941    -- Write --
 942    -----------
 943
 944    procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
 945
 946    procedure Write
 947      (Stream    : access Root_Stream_Type'Class;
 948       Container : Map)
 949    is
 950    begin
 951       Write_Nodes (Stream, Container.HT);
 952    end Write;
 953
 954    ----------------
 955    -- Write_Node --
 956    ----------------
 957
 958    procedure Write_Node
 959      (Stream : access Root_Stream_Type'Class;
 960       Node   : Node_Access)
 961    is
 962    begin
 963       Key_Type'Output (Stream, Node.Key.all);
 964       Element_Type'Output (Stream, Node.Element.all);
 965    end Write_Node;
 966
 967 end Ada.Containers.Indefinite_Hashed_Maps;