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