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