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-2009, 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 3,  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.                                     --
  17 --                                                                          --
  18 -- As a special exception under Section 7 of GPL version 3, you are granted --
  19 -- additional permissions described in the GCC Runtime Library Exception,   --
  20 -- version 3.1, as published by the Free Software Foundation.               --
  21 --                                                                          --
  22 -- You should have received a copy of the GNU General Public License and    --
  23 -- a copy of the GCC Runtime Library Exception along with this program;     --
  24 -- see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see    --
  25 -- <http://www.gnu.org/licenses/>.                                          --
  26 --                                                                          --
  27 -- This unit was originally developed by Matthew J Heaney.                  --
  28 ------------------------------------------------------------------------------
  29
  30 with Ada.Unchecked_Deallocation;
  31
  32 with Ada.Containers.Hash_Tables.Generic_Operations;
  33 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Operations);
  34
  35 with Ada.Containers.Hash_Tables.Generic_Keys;
  36 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Keys);
  37
  38 package body Ada.Containers.Hashed_Maps is
  39
  40    -----------------------
  41    -- Local Subprograms --
  42    -----------------------
  43
  44    function Copy_Node
  45      (Source : Node_Access) return Node_Access;
  46    pragma Inline (Copy_Node);
  47
  48    function Equivalent_Key_Node
  49      (Key  : Key_Type;
  50       Node : Node_Access) return Boolean;
  51    pragma Inline (Equivalent_Key_Node);
  52
  53    procedure Free (X : in out Node_Access);
  54
  55    function Find_Equal_Key
  56      (R_HT   : Hash_Table_Type;
  57       L_Node : Node_Access) return Boolean;
  58
  59    function Hash_Node (Node : Node_Access) return Hash_Type;
  60    pragma Inline (Hash_Node);
  61
  62    function Next (Node : Node_Access) return Node_Access;
  63    pragma Inline (Next);
  64
  65    function Read_Node
  66      (Stream : not null access Root_Stream_Type'Class) return Node_Access;
  67    pragma Inline (Read_Node);
  68
  69    procedure Set_Next (Node : Node_Access; Next : Node_Access);
  70    pragma Inline (Set_Next);
  71
  72    function Vet (Position : Cursor) return Boolean;
  73
  74    procedure Write_Node
  75      (Stream : not null access Root_Stream_Type'Class;
  76       Node   : Node_Access);
  77    pragma Inline (Write_Node);
  78
  79    --------------------------
  80    -- Local Instantiations --
  81    --------------------------
  82
  83    package HT_Ops is new Hash_Tables.Generic_Operations
  84      (HT_Types  => HT_Types,
  85       Hash_Node => Hash_Node,
  86       Next      => Next,
  87       Set_Next  => Set_Next,
  88       Copy_Node => Copy_Node,
  89       Free      => Free);
  90
  91    package Key_Ops is new Hash_Tables.Generic_Keys
  92      (HT_Types        => HT_Types,
  93       Next            => Next,
  94       Set_Next        => Set_Next,
  95       Key_Type        => Key_Type,
  96       Hash            => Hash,
  97       Equivalent_Keys => Equivalent_Key_Node);
  98
  99    function Is_Equal is new HT_Ops.Generic_Equal (Find_Equal_Key);
 100
 101    procedure Read_Nodes  is new HT_Ops.Generic_Read (Read_Node);
 102    procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
 103
 104    ---------
 105    -- "=" --
 106    ---------
 107
 108    function "=" (Left, Right : Map) return Boolean is
 109    begin
 110       return Is_Equal (Left.HT, Right.HT);
 111    end "=";
 112
 113    ------------
 114    -- Adjust --
 115    ------------
 116
 117    procedure Adjust (Container : in out Map) is
 118    begin
 119       HT_Ops.Adjust (Container.HT);
 120    end Adjust;
 121
 122    --------------
 123    -- Capacity --
 124    --------------
 125
 126    function Capacity (Container : Map) return Count_Type is
 127    begin
 128       return HT_Ops.Capacity (Container.HT);
 129    end Capacity;
 130
 131    -----------
 132    -- Clear --
 133    -----------
 134
 135    procedure Clear (Container : in out Map) is
 136    begin
 137       HT_Ops.Clear (Container.HT);
 138    end Clear;
 139
 140    --------------
 141    -- Contains --
 142    --------------
 143
 144    function Contains (Container : Map; Key : Key_Type) return Boolean is
 145    begin
 146       return Find (Container, Key) /= No_Element;
 147    end Contains;
 148
 149    ---------------
 150    -- Copy_Node --
 151    ---------------
 152
 153    function Copy_Node
 154      (Source : Node_Access) return Node_Access
 155    is
 156       Target : constant Node_Access :=
 157                  new Node_Type'(Key     => Source.Key,
 158                                 Element => Source.Element,
 159                                 Next    => null);
 160    begin
 161       return Target;
 162    end Copy_Node;
 163
 164    ------------
 165    -- Delete --
 166    ------------
 167
 168    procedure Delete (Container : in out Map; Key : Key_Type) is
 169       X : Node_Access;
 170
 171    begin
 172       Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
 173
 174       if X = null then
 175          raise Constraint_Error with "attempt to delete key not in map";
 176       end if;
 177
 178       Free (X);
 179    end Delete;
 180
 181    procedure Delete (Container : in out Map; Position : in out Cursor) is
 182    begin
 183       if Position.Node = null then
 184          raise Constraint_Error with
 185            "Position cursor of Delete equals No_Element";
 186       end if;
 187
 188       if Position.Container /= Container'Unrestricted_Access then
 189          raise Program_Error with
 190            "Position cursor of Delete designates wrong map";
 191       end if;
 192
 193       if Container.HT.Busy > 0 then
 194          raise Program_Error with
 195            "Delete attempted to tamper with elements (map is busy)";
 196       end if;
 197
 198       pragma Assert (Vet (Position), "bad cursor in Delete");
 199
 200       HT_Ops.Delete_Node_Sans_Free (Container.HT, Position.Node);
 201
 202       Free (Position.Node);
 203       Position.Container := null;
 204    end Delete;
 205
 206    -------------
 207    -- Element --
 208    -------------
 209
 210    function Element (Container : Map; Key : Key_Type) return Element_Type is
 211       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
 212
 213    begin
 214       if Node = null then
 215          raise Constraint_Error with
 216            "no element available because key not in map";
 217       end if;
 218
 219       return Node.Element;
 220    end Element;
 221
 222    function Element (Position : Cursor) return Element_Type is
 223    begin
 224       if Position.Node = null then
 225          raise Constraint_Error with
 226            "Position cursor of function Element equals No_Element";
 227       end if;
 228
 229       pragma Assert (Vet (Position), "bad cursor in function Element");
 230
 231       return Position.Node.Element;
 232    end Element;
 233
 234    -------------------------
 235    -- Equivalent_Key_Node --
 236    -------------------------
 237
 238    function Equivalent_Key_Node
 239      (Key  : Key_Type;
 240       Node : Node_Access) return Boolean is
 241    begin
 242       return Equivalent_Keys (Key, Node.Key);
 243    end Equivalent_Key_Node;
 244
 245    ---------------------
 246    -- Equivalent_Keys --
 247    ---------------------
 248
 249    function Equivalent_Keys (Left, Right : Cursor)
 250      return Boolean is
 251    begin
 252       if Left.Node = null then
 253          raise Constraint_Error with
 254            "Left cursor of Equivalent_Keys equals No_Element";
 255       end if;
 256
 257       if Right.Node = null then
 258          raise Constraint_Error with
 259            "Right cursor of Equivalent_Keys equals No_Element";
 260       end if;
 261
 262       pragma Assert (Vet (Left), "Left cursor of Equivalent_Keys is bad");
 263       pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad");
 264
 265       return Equivalent_Keys (Left.Node.Key, Right.Node.Key);
 266    end Equivalent_Keys;
 267
 268    function Equivalent_Keys (Left : Cursor; Right : Key_Type) return Boolean is
 269    begin
 270       if Left.Node = null then
 271          raise Constraint_Error with
 272            "Left cursor of Equivalent_Keys equals No_Element";
 273       end if;
 274
 275       pragma Assert (Vet (Left), "Left cursor in Equivalent_Keys is bad");
 276
 277       return Equivalent_Keys (Left.Node.Key, Right);
 278    end Equivalent_Keys;
 279
 280    function Equivalent_Keys (Left : Key_Type; Right : Cursor) return Boolean is
 281    begin
 282       if Right.Node = null then
 283          raise Constraint_Error with
 284            "Right cursor of Equivalent_Keys equals No_Element";
 285       end if;
 286
 287       pragma Assert (Vet (Right), "Right cursor of Equivalent_Keys is bad");
 288
 289       return Equivalent_Keys (Left, Right.Node.Key);
 290    end Equivalent_Keys;
 291
 292    -------------
 293    -- Exclude --
 294    -------------
 295
 296    procedure Exclude (Container : in out Map; Key : Key_Type) is
 297       X : Node_Access;
 298    begin
 299       Key_Ops.Delete_Key_Sans_Free (Container.HT, Key, X);
 300       Free (X);
 301    end Exclude;
 302
 303    --------------
 304    -- Finalize --
 305    --------------
 306
 307    procedure Finalize (Container : in out Map) is
 308    begin
 309       HT_Ops.Finalize (Container.HT);
 310    end Finalize;
 311
 312    ----------
 313    -- Find --
 314    ----------
 315
 316    function Find (Container : Map; Key : Key_Type) return Cursor is
 317       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
 318
 319    begin
 320       if Node = null then
 321          return No_Element;
 322       end if;
 323
 324       return Cursor'(Container'Unchecked_Access, Node);
 325    end Find;
 326
 327    --------------------
 328    -- Find_Equal_Key --
 329    --------------------
 330
 331    function Find_Equal_Key
 332      (R_HT   : Hash_Table_Type;
 333       L_Node : Node_Access) return Boolean
 334    is
 335       R_Index : constant Hash_Type := Key_Ops.Index (R_HT, L_Node.Key);
 336       R_Node  : Node_Access := R_HT.Buckets (R_Index);
 337
 338    begin
 339       while R_Node /= null loop
 340          if Equivalent_Keys (L_Node.Key, R_Node.Key) then
 341             return L_Node.Element = R_Node.Element;
 342          end if;
 343
 344          R_Node := R_Node.Next;
 345       end loop;
 346
 347       return False;
 348    end Find_Equal_Key;
 349
 350    -----------
 351    -- First --
 352    -----------
 353
 354    function First (Container : Map) return Cursor is
 355       Node : constant Node_Access := HT_Ops.First (Container.HT);
 356
 357    begin
 358       if Node = null then
 359          return No_Element;
 360       end if;
 361
 362       return Cursor'(Container'Unchecked_Access, Node);
 363    end First;
 364
 365    ----------
 366    -- Free --
 367    ----------
 368
 369    procedure Free (X : in out Node_Access) is
 370       procedure Deallocate is
 371          new Ada.Unchecked_Deallocation (Node_Type, Node_Access);
 372    begin
 373       if X /= null then
 374          X.Next := X;     --  detect mischief (in Vet)
 375          Deallocate (X);
 376       end if;
 377    end Free;
 378
 379    -----------------
 380    -- Has_Element --
 381    -----------------
 382
 383    function Has_Element (Position : Cursor) return Boolean is
 384    begin
 385       pragma Assert (Vet (Position), "bad cursor in Has_Element");
 386       return Position.Node /= null;
 387    end Has_Element;
 388
 389    ---------------
 390    -- Hash_Node --
 391    ---------------
 392
 393    function Hash_Node (Node : Node_Access) return Hash_Type is
 394    begin
 395       return Hash (Node.Key);
 396    end Hash_Node;
 397
 398    -------------
 399    -- Include --
 400    -------------
 401
 402    procedure Include
 403      (Container : in out Map;
 404       Key       : Key_Type;
 405       New_Item  : Element_Type)
 406    is
 407       Position : Cursor;
 408       Inserted : Boolean;
 409
 410    begin
 411       Insert (Container, Key, New_Item, Position, Inserted);
 412
 413       if not Inserted then
 414          if Container.HT.Lock > 0 then
 415             raise Program_Error with
 416               "Include attempted to tamper with cursors (map is locked)";
 417          end if;
 418
 419          Position.Node.Key := Key;
 420          Position.Node.Element := New_Item;
 421       end if;
 422    end Include;
 423
 424    ------------
 425    -- Insert --
 426    ------------
 427
 428    procedure Insert
 429      (Container : in out Map;
 430       Key       : Key_Type;
 431       Position  : out Cursor;
 432       Inserted  : out Boolean)
 433    is
 434       function New_Node (Next : Node_Access) return Node_Access;
 435       pragma Inline (New_Node);
 436
 437       procedure Local_Insert is
 438         new Key_Ops.Generic_Conditional_Insert (New_Node);
 439
 440       --------------
 441       -- New_Node --
 442       --------------
 443
 444       function New_Node (Next : Node_Access) return Node_Access is
 445       begin
 446          return new Node_Type'(Key     => Key,
 447                                Element => <>,
 448                                Next    => Next);
 449       end New_Node;
 450
 451       HT : Hash_Table_Type renames Container.HT;
 452
 453    --  Start of processing for Insert
 454
 455    begin
 456       if HT_Ops.Capacity (HT) = 0 then
 457          HT_Ops.Reserve_Capacity (HT, 1);
 458       end if;
 459
 460       Local_Insert (HT, Key, Position.Node, Inserted);
 461
 462       if Inserted
 463         and then HT.Length > HT_Ops.Capacity (HT)
 464       then
 465          HT_Ops.Reserve_Capacity (HT, HT.Length);
 466       end if;
 467
 468       Position.Container := Container'Unchecked_Access;
 469    end Insert;
 470
 471    procedure Insert
 472      (Container : in out Map;
 473       Key       : Key_Type;
 474       New_Item  : Element_Type;
 475       Position  : out Cursor;
 476       Inserted  : out Boolean)
 477    is
 478       function New_Node (Next : Node_Access) return Node_Access;
 479       pragma Inline (New_Node);
 480
 481       procedure Local_Insert is
 482         new Key_Ops.Generic_Conditional_Insert (New_Node);
 483
 484       --------------
 485       -- New_Node --
 486       --------------
 487
 488       function New_Node (Next : Node_Access) return Node_Access is
 489       begin
 490          return new Node_Type'(Key, New_Item, Next);
 491       end New_Node;
 492
 493       HT : Hash_Table_Type renames Container.HT;
 494
 495    --  Start of processing for Insert
 496
 497    begin
 498       if HT_Ops.Capacity (HT) = 0 then
 499          HT_Ops.Reserve_Capacity (HT, 1);
 500       end if;
 501
 502       Local_Insert (HT, Key, Position.Node, Inserted);
 503
 504       if Inserted
 505         and then HT.Length > HT_Ops.Capacity (HT)
 506       then
 507          HT_Ops.Reserve_Capacity (HT, HT.Length);
 508       end if;
 509
 510       Position.Container := Container'Unchecked_Access;
 511    end Insert;
 512
 513    procedure Insert
 514      (Container : in out Map;
 515       Key       : Key_Type;
 516       New_Item  : Element_Type)
 517    is
 518       Position : Cursor;
 519       pragma Unreferenced (Position);
 520
 521       Inserted : Boolean;
 522
 523    begin
 524       Insert (Container, Key, New_Item, Position, Inserted);
 525
 526       if not Inserted then
 527          raise Constraint_Error with
 528            "attempt to insert key already in map";
 529       end if;
 530    end Insert;
 531
 532    --------------
 533    -- Is_Empty --
 534    --------------
 535
 536    function Is_Empty (Container : Map) return Boolean is
 537    begin
 538       return Container.HT.Length = 0;
 539    end Is_Empty;
 540
 541    -------------
 542    -- Iterate --
 543    -------------
 544
 545    procedure Iterate
 546      (Container : Map;
 547       Process   : not null access procedure (Position : Cursor))
 548    is
 549       procedure Process_Node (Node : Node_Access);
 550       pragma Inline (Process_Node);
 551
 552       procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node);
 553
 554       ------------------
 555       -- Process_Node --
 556       ------------------
 557
 558       procedure Process_Node (Node : Node_Access) is
 559       begin
 560          Process (Cursor'(Container'Unchecked_Access, Node));
 561       end Process_Node;
 562
 563       B : Natural renames Container'Unrestricted_Access.HT.Busy;
 564
 565    --  Start of processing for Iterate
 566
 567    begin
 568       B := B + 1;
 569
 570       begin
 571          Local_Iterate (Container.HT);
 572       exception
 573          when others =>
 574             B := B - 1;
 575             raise;
 576       end;
 577
 578       B := B - 1;
 579    end Iterate;
 580
 581    ---------
 582    -- Key --
 583    ---------
 584
 585    function Key (Position : Cursor) return Key_Type is
 586    begin
 587       if Position.Node = null then
 588          raise Constraint_Error with
 589            "Position cursor of function Key equals No_Element";
 590       end if;
 591
 592       pragma Assert (Vet (Position), "bad cursor in function Key");
 593
 594       return Position.Node.Key;
 595    end Key;
 596
 597    ------------
 598    -- Length --
 599    ------------
 600
 601    function Length (Container : Map) return Count_Type is
 602    begin
 603       return Container.HT.Length;
 604    end Length;
 605
 606    ----------
 607    -- Move --
 608    ----------
 609
 610    procedure Move
 611      (Target : in out Map;
 612       Source : in out Map)
 613    is
 614    begin
 615       HT_Ops.Move (Target => Target.HT, Source => Source.HT);
 616    end Move;
 617
 618    ----------
 619    -- Next --
 620    ----------
 621
 622    function Next (Node : Node_Access) return Node_Access is
 623    begin
 624       return Node.Next;
 625    end Next;
 626
 627    function Next (Position : Cursor) return Cursor is
 628    begin
 629       if Position.Node = null then
 630          return No_Element;
 631       end if;
 632
 633       pragma Assert (Vet (Position), "bad cursor in function Next");
 634
 635       declare
 636          HT   : Hash_Table_Type renames Position.Container.HT;
 637          Node : constant Node_Access := HT_Ops.Next (HT, Position.Node);
 638
 639       begin
 640          if Node = null then
 641             return No_Element;
 642          end if;
 643
 644          return Cursor'(Position.Container, Node);
 645       end;
 646    end Next;
 647
 648    procedure Next (Position : in out Cursor) is
 649    begin
 650       Position := Next (Position);
 651    end Next;
 652
 653    -------------------
 654    -- Query_Element --
 655    -------------------
 656
 657    procedure Query_Element
 658      (Position : Cursor;
 659       Process  : not null access
 660                    procedure (Key : Key_Type; Element : Element_Type))
 661    is
 662    begin
 663       if Position.Node = null then
 664          raise Constraint_Error with
 665            "Position cursor of Query_Element equals No_Element";
 666       end if;
 667
 668       pragma Assert (Vet (Position), "bad cursor in Query_Element");
 669
 670       declare
 671          M  : Map renames Position.Container.all;
 672          HT : Hash_Table_Type renames M.HT'Unrestricted_Access.all;
 673
 674          B : Natural renames HT.Busy;
 675          L : Natural renames HT.Lock;
 676
 677       begin
 678          B := B + 1;
 679          L := L + 1;
 680
 681          declare
 682             K : Key_Type renames Position.Node.Key;
 683             E : Element_Type renames Position.Node.Element;
 684
 685          begin
 686             Process (K, E);
 687          exception
 688             when others =>
 689                L := L - 1;
 690                B := B - 1;
 691                raise;
 692          end;
 693
 694          L := L - 1;
 695          B := B - 1;
 696       end;
 697    end Query_Element;
 698
 699    ----------
 700    -- Read --
 701    ----------
 702
 703    procedure Read
 704      (Stream    : not null access Root_Stream_Type'Class;
 705       Container : out Map)
 706    is
 707    begin
 708       Read_Nodes (Stream, Container.HT);
 709    end Read;
 710
 711    procedure Read
 712      (Stream : not null access Root_Stream_Type'Class;
 713       Item   : out Cursor)
 714    is
 715    begin
 716       raise Program_Error with "attempt to stream map cursor";
 717    end Read;
 718
 719    ---------------
 720    -- Read_Node --
 721    ---------------
 722
 723    function Read_Node
 724      (Stream : not null access Root_Stream_Type'Class) return Node_Access
 725    is
 726       Node : Node_Access := new Node_Type;
 727
 728    begin
 729       Key_Type'Read (Stream, Node.Key);
 730       Element_Type'Read (Stream, Node.Element);
 731       return Node;
 732
 733    exception
 734       when others =>
 735          Free (Node);
 736          raise;
 737    end Read_Node;
 738
 739    -------------
 740    -- Replace --
 741    -------------
 742
 743    procedure Replace
 744      (Container : in out Map;
 745       Key       : Key_Type;
 746       New_Item  : Element_Type)
 747    is
 748       Node : constant Node_Access := Key_Ops.Find (Container.HT, Key);
 749
 750    begin
 751       if Node = null then
 752          raise Constraint_Error with
 753            "attempt to replace key not in map";
 754       end if;
 755
 756       if Container.HT.Lock > 0 then
 757          raise Program_Error with
 758            "Replace attempted to tamper with cursors (map is locked)";
 759       end if;
 760
 761       Node.Key := Key;
 762       Node.Element := New_Item;
 763    end Replace;
 764
 765    ---------------------
 766    -- Replace_Element --
 767    ---------------------
 768
 769    procedure Replace_Element
 770      (Container : in out Map;
 771       Position  : Cursor;
 772       New_Item  : Element_Type)
 773    is
 774    begin
 775       if Position.Node = null then
 776          raise Constraint_Error with
 777            "Position cursor of Replace_Element equals No_Element";
 778       end if;
 779
 780       if Position.Container /= Container'Unrestricted_Access then
 781          raise Program_Error with
 782            "Position cursor of Replace_Element designates wrong map";
 783       end if;
 784
 785       if Position.Container.HT.Lock > 0 then
 786          raise Program_Error with
 787            "Replace_Element attempted to tamper with cursors (map is locked)";
 788       end if;
 789
 790       pragma Assert (Vet (Position), "bad cursor in Replace_Element");
 791
 792       Position.Node.Element := New_Item;
 793    end Replace_Element;
 794
 795    ----------------------
 796    -- Reserve_Capacity --
 797    ----------------------
 798
 799    procedure Reserve_Capacity
 800      (Container : in out Map;
 801       Capacity  : Count_Type)
 802    is
 803    begin
 804       HT_Ops.Reserve_Capacity (Container.HT, Capacity);
 805    end Reserve_Capacity;
 806
 807    --------------
 808    -- Set_Next --
 809    --------------
 810
 811    procedure Set_Next (Node : Node_Access; Next : Node_Access) is
 812    begin
 813       Node.Next := Next;
 814    end Set_Next;
 815
 816    --------------------
 817    -- Update_Element --
 818    --------------------
 819
 820    procedure Update_Element
 821      (Container : in out Map;
 822       Position  : Cursor;
 823       Process   : not null access procedure (Key     : Key_Type;
 824                                              Element : in out Element_Type))
 825    is
 826    begin
 827       if Position.Node = null then
 828          raise Constraint_Error with
 829            "Position cursor of Update_Element equals No_Element";
 830       end if;
 831
 832       if Position.Container /= Container'Unrestricted_Access then
 833          raise Program_Error with
 834            "Position cursor of Update_Element designates wrong map";
 835       end if;
 836
 837       pragma Assert (Vet (Position), "bad cursor in Update_Element");
 838
 839       declare
 840          HT : Hash_Table_Type renames Container.HT;
 841          B  : Natural renames HT.Busy;
 842          L  : Natural renames HT.Lock;
 843
 844       begin
 845          B := B + 1;
 846          L := L + 1;
 847
 848          declare
 849             K : Key_Type renames Position.Node.Key;
 850             E : Element_Type renames Position.Node.Element;
 851
 852          begin
 853             Process (K, E);
 854
 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;