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-2007, 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       pragma Unreferenced (Position);
 524
 525       Inserted : Boolean;
 526
 527    begin
 528       Insert (Container, Key, New_Item, Position, Inserted);
 529
 530       if not Inserted then
 531          raise Constraint_Error with
 532            "attempt to insert key already in map";
 533       end if;
 534    end Insert;
 535
 536    --------------
 537    -- Is_Empty --
 538    --------------
 539
 540    function Is_Empty (Container : Map) return Boolean is
 541    begin
 542       return Container.HT.Length = 0;
 543    end Is_Empty;
 544
 545    -------------
 546    -- Iterate --
 547    -------------
 548
 549    procedure Iterate
 550      (Container : Map;
 551       Process   : not null access procedure (Position : Cursor))
 552    is
 553       procedure Process_Node (Node : Node_Access);
 554       pragma Inline (Process_Node);
 555
 556       procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node);
 557
 558       ------------------
 559       -- Process_Node --
 560       ------------------
 561
 562       procedure Process_Node (Node : Node_Access) is
 563       begin
 564          Process (Cursor'(Container'Unchecked_Access, Node));
 565       end Process_Node;
 566
 567       B : Natural renames Container'Unrestricted_Access.HT.Busy;
 568
 569    --  Start of processing for Iterate
 570
 571    begin
 572       B := B + 1;
 573
 574       begin
 575          Local_Iterate (Container.HT);
 576       exception
 577          when others =>
 578             B := B - 1;
 579             raise;
 580       end;
 581
 582       B := B - 1;
 583    end Iterate;
 584
 585    ---------
 586    -- Key --
 587    ---------
 588
 589    function Key (Position : Cursor) return Key_Type is
 590    begin
 591       if Position.Node = null then
 592          raise Constraint_Error with
 593            "Position cursor of function Key equals No_Element";
 594       end if;
 595
 596       pragma Assert (Vet (Position), "bad cursor in function Key");
 597
 598       return Position.Node.Key;
 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    function Next (Position : Cursor) return Cursor is
 632    begin
 633       if Position.Node = null then
 634          return No_Element;
 635       end if;
 636
 637       pragma Assert (Vet (Position), "bad cursor in function Next");
 638
 639       declare
 640          HT   : Hash_Table_Type renames Position.Container.HT;
 641          Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
 642
 643       begin
 644          if Node = null then
 645             return No_Element;
 646          end if;
 647
 648          return Cursor'(Position.Container, Node);
 649       end;
 650    end Next;
 651
 652    procedure Next (Position : in out Cursor) is
 653    begin
 654       Position := Next (Position);
 655    end Next;
 656
 657    -------------------
 658    -- Query_Element --
 659    -------------------
 660
 661    procedure Query_Element
 662      (Position : Cursor;
 663       Process  : not null access
 664                    procedure (Key : Key_Type; Element : Element_Type))
 665    is
 666    begin
 667       if Position.Node = null then
 668          raise Constraint_Error with
 669            "Position cursor of Query_Element equals No_Element";
 670       end if;
 671
 672       pragma Assert (Vet (Position), "bad cursor in Query_Element");
 673
 674       declare
 675          M  : Map renames Position.Container.all;
 676          HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
 677
 678          B : Natural renames HT.Busy;
 679          L : Natural renames HT.Lock;
 680
 681       begin
 682          B := B + 1;
 683          L := L + 1;
 684
 685          declare
 686             K : Key_Type renames Position.Node.Key;
 687             E : Element_Type renames Position.Node.Element;
 688
 689          begin
 690             Process (K, E);
 691          exception
 692             when others =>
 693                L := L - 1;
 694                B := B - 1;
 695                raise;
 696          end;
 697
 698          L := L - 1;
 699          B := B - 1;
 700       end;
 701    end Query_Element;
 702
 703    ----------
 704    -- Read --
 705    ----------
 706
 707    procedure Read
 708      (Stream    : not null access Root_Stream_Type'Class;
 709       Container : out Map)
 710    is
 711    begin
 712       Read_Nodes (Stream, Container.HT);
 713    end Read;
 714
 715    procedure Read
 716      (Stream : not null access Root_Stream_Type'Class;
 717       Item   : out Cursor)
 718    is
 719    begin
 720       raise Program_Error with "attempt to stream map cursor";
 721    end Read;
 722
 723    ---------------
 724    -- Read_Node --
 725    ---------------
 726
 727    function Read_Node
 728      (Stream : not null access Root_Stream_Type'Class) return Node_Access
 729    is
 730       Node : Node_Access := new Node_Type;
 731
 732    begin
 733       Key_Type'Read (Stream, Node.Key);
 734       Element_Type'Read (Stream, Node.Element);
 735       return Node;
 736
 737    exception
 738       when others =>
 739          Free (Node);
 740          raise;
 741    end Read_Node;
 742
 743    -------------
 744    -- Replace --
 745    -------------
 746
 747    procedure Replace
 748      (Container : in out Map;
 749       Key       : Key_Type;
 750       New_Item  : Element_Type)
 751    is
 752       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
 753
 754    begin
 755       if Node = null then
 756          raise Constraint_Error with
 757            "attempt to replace key not in map";
 758       end if;
 759
 760       if Container.HT.Lock > 0 then
 761          raise Program_Error with
 762            "Replace attempted to tamper with cursors (map is locked)";
 763       end if;
 764
 765       Node.Key := Key;
 766       Node.Element := New_Item;
 767    end Replace;
 768
 769    ---------------------
 770    -- Replace_Element --
 771    ---------------------
 772
 773    procedure Replace_Element
 774      (Container : in out Map;
 775       Position  : Cursor;
 776       New_Item  : Element_Type)
 777    is
 778    begin
 779       if Position.Node = null then
 780          raise Constraint_Error with
 781            "Position cursor of Replace_Element equals No_Element";
 782       end if;
 783
 784       if Position.Container /= Container'Unrestricted_Access then
 785          raise Program_Error with
 786            "Position cursor of Replace_Element designates wrong map";
 787       end if;
 788
 789       if Position.Container.HT.Lock > 0 then
 790          raise Program_Error with
 791            "Replace_Element attempted to tamper with cursors (map is locked)";
 792       end if;
 793
 794       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
 795
 796       Position.Node.Element := New_Item;
 797    end Replace_Element;
 798
 799    ----------------------
 800    -- Reserve_Capacity --
 801    ----------------------
 802
 803    procedure Reserve_Capacity
 804      (Container : in out Map;
 805       Capacity  : Count_Type)
 806    is
 807    begin
 808       HT_Ops.Reserve_Capacity (Container.HT, Capacity);
 809    end Reserve_Capacity;
 810
 811    --------------
 812    -- Set_Next --
 813    --------------
 814
 815    procedure Set_Next (Node : Node_Access; Next : Node_Access) is
 816    begin
 817       Node.Next := Next;
 818    end Set_Next;
 819
 820    --------------------
 821    -- Update_Element --
 822    --------------------
 823
 824    procedure Update_Element
 825      (Container : in out Map;
 826       Position  : Cursor;
 827       Process   : not null access procedure (Key     : Key_Type;
 828                                              Element : in out Element_Type))
 829    is
 830    begin
 831       if Position.Node = null then
 832          raise Constraint_Error with
 833            "Position cursor of Update_Element equals No_Element";
 834       end if;
 835
 836       if Position.Container /= Container'Unrestricted_Access then
 837          raise Program_Error with
 838            "Position cursor of Update_Element designates wrong map";
 839       end if;
 840
 841       pragma Assert (Vet (Position), "bad cursor in Update_Element");
 842
 843       declare
 844          HT : Hash_Table_Type renames Container.HT;
 845          B  : Natural renames HT.Busy;
 846          L  : Natural renames HT.Lock;
 847
 848       begin
 849          B := B + 1;
 850          L := L + 1;
 851
 852          declare
 853             K : Key_Type renames Position.Node.Key;
 854             E : Element_Type renames Position.Node.Element;
 855
 856          begin
 857             Process (K, E);
 858
 859          exception
 860             when others =>
 861                L := L - 1;
 862                B := B - 1;
 863                raise;
 864          end;
 865
 866          L := L - 1;
 867          B := B - 1;
 868       end;
 869    end Update_Element;
 870
 871    ---------
 872    -- Vet --
 873    ---------
 874
 875    function Vet (Position : Cursor) return Boolean is
 876    begin
 877       if Position.Node = null then
 878          return Position.Container = null;
 879       end if;
 880
 881       if Position.Container = null then
 882          return False;
 883       end if;
 884
 885       if Position.Node.Next = Position.Node then
 886          return False;
 887       end if;
 888
 889       declare
 890          HT : Hash_Table_Type renames Position.Container.HT;
 891          X  : Node_Access;
 892
 893       begin
 894          if HT.Length = 0 then
 895             return False;
 896          end if;
 897
 898          if HT.Buckets = null
 899            or else HT.Buckets'Length = 0
 900          then
 901             return False;
 902          end if;
 903
 904          X := HT.Buckets (Key_Ops.Index (HT, Position.Node.Key));
 905
 906          for J in 1 .. HT.Length loop
 907             if X = Position.Node then
 908                return True;
 909             end if;
 910
 911             if X = null then
 912                return False;
 913             end if;
 914
 915             if X = X.Next then  --  to prevent endless loop
 916                return False;
 917             end if;
 918
 919             X := X.Next;
 920          end loop;
 921
 922          return False;
 923       end;
 924    end Vet;
 925
 926    -----------
 927    -- Write --
 928    -----------
 929
 930    procedure Write
 931      (Stream    : not null access Root_Stream_Type'Class;
 932       Container : Map)
 933    is
 934    begin
 935       Write_Nodes (Stream, Container.HT);
 936    end Write;
 937
 938    procedure Write
 939      (Stream : not null access Root_Stream_Type'Class;
 940       Item   : Cursor)
 941    is
 942    begin
 943       raise Program_Error with "attempt to stream map cursor";
 944    end Write;
 945
 946    ----------------
 947    -- Write_Node --
 948    ----------------
 949
 950    procedure Write_Node
 951      (Stream : not null access Root_Stream_Type'Class;
 952       Node   : Node_Access)
 953    is
 954    begin
 955       Key_Type'Write (Stream, Node.Key);
 956       Element_Type'Write (Stream, Node.Element);
 957    end Write_Node;
 958
 959 end Ada.Containers.Hashed_Maps;