gcc/ada/a-cfhama.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --    A D A . C O N T A I N E R S . F O R M A L _ H A S H E D _ M A P S     --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2010-2012, 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
  28 with Ada.Containers.Hash_Tables.Generic_Bounded_Operations;
  29 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Operations);
  30
  31 with Ada.Containers.Hash_Tables.Generic_Bounded_Keys;
  32 pragma Elaborate_All (Ada.Containers.Hash_Tables.Generic_Bounded_Keys);
  33
  34 with Ada.Containers.Prime_Numbers; use Ada.Containers.Prime_Numbers;
  35
  36 with System;  use type System.Address;
  37
  38 package body Ada.Containers.Formal_Hashed_Maps is
  39
  40    -----------------------
  41    -- Local Subprograms --
  42    -----------------------
  43
  44    --  All local subprograms require comments ???
  45
  46    function Equivalent_Keys
  47      (Key  : Key_Type;
  48       Node : Node_Type) return Boolean;
  49    pragma Inline (Equivalent_Keys);
  50
  51    procedure Free
  52      (HT : in out Map;
  53       X  : Count_Type);
  54
  55    generic
  56       with procedure Set_Element (Node : in out Node_Type);
  57    procedure Generic_Allocate
  58      (HT   : in out Map;
  59       Node : out Count_Type);
  60
  61    function Hash_Node (Node : Node_Type) return Hash_Type;
  62    pragma Inline (Hash_Node);
  63
  64    function Next (Node : Node_Type) return Count_Type;
  65    pragma Inline (Next);
  66
  67    procedure Set_Next (Node : in out Node_Type; Next : Count_Type);
  68    pragma Inline (Set_Next);
  69
  70    function Vet (Container : Map; Position : Cursor) return Boolean;
  71
  72    --------------------------
  73    -- Local Instantiations --
  74    --------------------------
  75
  76    package HT_Ops is
  77      new Hash_Tables.Generic_Bounded_Operations
  78        (HT_Types  => HT_Types,
  79         Hash_Node => Hash_Node,
  80         Next      => Next,
  81         Set_Next  => Set_Next);
  82
  83    package Key_Ops is
  84      new Hash_Tables.Generic_Bounded_Keys
  85        (HT_Types        => HT_Types,
  86         Next            => Next,
  87         Set_Next        => Set_Next,
  88         Key_Type        => Key_Type,
  89         Hash            => Hash,
  90         Equivalent_Keys => Equivalent_Keys);
  91
  92    ---------
  93    -- "=" --
  94    ---------
  95
  96    function "=" (Left, Right : Map) return Boolean is
  97    begin
  98       if Length (Left) /= Length (Right) then
  99          return False;
 100       end if;
 101
 102       if Length (Left) = 0 then
 103          return True;
 104       end if;
 105
 106       declare
 107          Node  : Count_Type;
 108          ENode : Count_Type;
 109
 110       begin
 111          Node := Left.First.Node;
 112          while Node /= 0 loop
 113             ENode := Find (Container => Right,
 114                            Key       => Left.Nodes (Node).Key).Node;
 115
 116             if ENode = 0 or else
 117               Right.Nodes (ENode).Element /= Left.Nodes (Node).Element
 118             then
 119                return False;
 120             end if;
 121
 122             Node := HT_Ops.Next (Left, Node);
 123          end loop;
 124
 125          return True;
 126       end;
 127    end "=";
 128
 129    ------------
 130    -- Assign --
 131    ------------
 132
 133    procedure Assign (Target : in out Map; Source : Map) is
 134       procedure Insert_Element (Source_Node : Count_Type);
 135       pragma Inline (Insert_Element);
 136
 137       procedure Insert_Elements is
 138         new HT_Ops.Generic_Iteration (Insert_Element);
 139
 140       --------------------
 141       -- Insert_Element --
 142       --------------------
 143
 144       procedure Insert_Element (Source_Node : Count_Type) is
 145          N : Node_Type renames Source.Nodes (Source_Node);
 146       begin
 147          Target.Insert (N.Key, N.Element);
 148       end Insert_Element;
 149
 150       --  Start of processing for Assign
 151
 152    begin
 153       if Target'Address = Source'Address then
 154          return;
 155       end if;
 156
 157       if Target.Capacity < Length (Source) then
 158          raise Constraint_Error with  -- correct exception ???
 159            "Source length exceeds Target capacity";
 160       end if;
 161
 162       --  Check busy bits
 163
 164       Clear (Target);
 165
 166       Insert_Elements (Source);
 167    end Assign;
 168
 169    --------------
 170    -- Capacity --
 171    --------------
 172
 173    function Capacity (Container : Map) return Count_Type is
 174    begin
 175       return Container.Nodes'Length;
 176    end Capacity;
 177
 178    -----------
 179    -- Clear --
 180    -----------
 181
 182    procedure Clear (Container : in out Map) is
 183    begin
 184       HT_Ops.Clear (Container);
 185    end Clear;
 186
 187    --------------
 188    -- Contains --
 189    --------------
 190
 191    function Contains (Container : Map; Key : Key_Type) return Boolean is
 192    begin
 193       return Find (Container, Key) /= No_Element;
 194    end Contains;
 195
 196    ----------
 197    -- Copy --
 198    ----------
 199
 200    function Copy
 201      (Source   : Map;
 202       Capacity : Count_Type := 0) return Map
 203    is
 204       C      : constant Count_Type :=
 205         Count_Type'Max (Capacity, Source.Capacity);
 206       H      : Hash_Type;
 207       N      : Count_Type;
 208       Target : Map (C, Source.Modulus);
 209       Cu     : Cursor;
 210
 211    begin
 212       Target.Length := Source.Length;
 213       Target.Free := Source.Free;
 214
 215       H := 1;
 216       while H <= Source.Modulus loop
 217          Target.Buckets (H) := Source.Buckets (H);
 218          H := H + 1;
 219       end loop;
 220
 221       N := 1;
 222       while N <= Source.Capacity loop
 223          Target.Nodes (N) := Source.Nodes (N);
 224          N := N + 1;
 225       end loop;
 226
 227       while N <= C loop
 228          Cu := (Node => N);
 229          Free (Target, Cu.Node);
 230          N := N + 1;
 231       end loop;
 232
 233       return Target;
 234    end Copy;
 235
 236    ---------------------
 237    -- Default_Modulus --
 238    ---------------------
 239
 240    function Default_Modulus (Capacity : Count_Type) return Hash_Type is
 241    begin
 242       return To_Prime (Capacity);
 243    end Default_Modulus;
 244
 245    ------------
 246    -- Delete --
 247    ------------
 248
 249    procedure Delete (Container : in out Map; Key : Key_Type) is
 250       X : Count_Type;
 251
 252    begin
 253       Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
 254
 255       if X = 0 then
 256          raise Constraint_Error with "attempt to delete key not in map";
 257       end if;
 258
 259       Free (Container, X);
 260    end Delete;
 261
 262    procedure Delete (Container : in out Map; Position : in out Cursor) is
 263    begin
 264       if not Has_Element (Container, Position) then
 265          raise Constraint_Error with
 266            "Position cursor of Delete has no element";
 267       end if;
 268
 269       if Container.Busy > 0 then
 270          raise Program_Error with
 271            "Delete attempted to tamper with elements (map is busy)";
 272       end if;
 273
 274       pragma Assert (Vet (Container, Position), "bad cursor in Delete");
 275
 276       HT_Ops.Delete_Node_Sans_Free (Container, Position.Node);
 277
 278       Free (Container, Position.Node);
 279    end Delete;
 280
 281    -------------
 282    -- Element --
 283    -------------
 284
 285    function Element (Container : Map; Key : Key_Type) return Element_Type is
 286       Node : constant Count_Type := Find (Container, Key).Node;
 287
 288    begin
 289       if Node = 0 then
 290          raise Constraint_Error with
 291            "no element available because key not in map";
 292       end if;
 293
 294       return Container.Nodes (Node).Element;
 295    end Element;
 296
 297    function Element (Container : Map; Position : Cursor) return Element_Type is
 298    begin
 299       if not Has_Element (Container, Position) then
 300          raise Constraint_Error with "Position cursor equals No_Element";
 301       end if;
 302
 303       pragma Assert (Vet (Container, Position),
 304                      "bad cursor in function Element");
 305
 306       return Container.Nodes (Position.Node).Element;
 307    end Element;
 308
 309    ---------------------
 310    -- Equivalent_Keys --
 311    ---------------------
 312
 313    function Equivalent_Keys
 314      (Key  : Key_Type;
 315       Node : Node_Type) return Boolean
 316    is
 317    begin
 318       return Equivalent_Keys (Key, Node.Key);
 319    end Equivalent_Keys;
 320
 321    function Equivalent_Keys
 322      (Left   : Map;
 323       CLeft  : Cursor;
 324       Right  : Map;
 325       CRight : Cursor) return Boolean
 326    is
 327    begin
 328       if not Has_Element (Left, CLeft) then
 329          raise Constraint_Error with
 330            "Left cursor of Equivalent_Keys has no element";
 331       end if;
 332
 333       if not Has_Element (Right, CRight) then
 334          raise Constraint_Error with
 335            "Right cursor of Equivalent_Keys has no element";
 336       end if;
 337
 338       pragma Assert (Vet (Left, CLeft),
 339                      "Left cursor of Equivalent_Keys is bad");
 340       pragma Assert (Vet (Right, CRight),
 341                      "Right cursor of Equivalent_Keys is bad");
 342
 343       declare
 344          LN : Node_Type renames Left.Nodes (CLeft.Node);
 345          RN : Node_Type renames Right.Nodes (CRight.Node);
 346       begin
 347          return Equivalent_Keys (LN.Key, RN.Key);
 348       end;
 349    end Equivalent_Keys;
 350
 351    function Equivalent_Keys
 352      (Left  : Map;
 353       CLeft : Cursor;
 354       Right : Key_Type) return Boolean
 355    is
 356    begin
 357       if not Has_Element (Left, CLeft) then
 358          raise Constraint_Error with
 359            "Left cursor of Equivalent_Keys has no element";
 360       end if;
 361
 362       pragma Assert (Vet (Left, CLeft),
 363                      "Left cursor in Equivalent_Keys is bad");
 364
 365       declare
 366          LN : Node_Type renames Left.Nodes (CLeft.Node);
 367       begin
 368          return Equivalent_Keys (LN.Key, Right);
 369       end;
 370    end Equivalent_Keys;
 371
 372    function Equivalent_Keys
 373      (Left   : Key_Type;
 374       Right  : Map;
 375       CRight : Cursor) return Boolean
 376    is
 377    begin
 378       if Has_Element (Right, CRight) then
 379          raise Constraint_Error with
 380            "Right cursor of Equivalent_Keys has no element";
 381       end if;
 382
 383       pragma Assert (Vet (Right, CRight),
 384                      "Right cursor of Equivalent_Keys is bad");
 385
 386       declare
 387          RN : Node_Type renames Right.Nodes (CRight.Node);
 388
 389       begin
 390          return Equivalent_Keys (Left, RN.Key);
 391       end;
 392    end Equivalent_Keys;
 393
 394    -------------
 395    -- Exclude --
 396    -------------
 397
 398    procedure Exclude (Container : in out Map; Key : Key_Type) is
 399       X : Count_Type;
 400    begin
 401       Key_Ops.Delete_Key_Sans_Free (Container, Key, X);
 402       Free (Container, X);
 403    end Exclude;
 404
 405    ----------
 406    -- Find --
 407    ----------
 408
 409    function Find (Container : Map; Key : Key_Type) return Cursor is
 410       Node : constant Count_Type := Key_Ops.Find (Container, Key);
 411
 412    begin
 413       if Node = 0 then
 414          return No_Element;
 415       end if;
 416
 417       return (Node => Node);
 418    end Find;
 419
 420    -----------
 421    -- First --
 422    -----------
 423
 424    function First (Container : Map) return Cursor is
 425       Node : constant Count_Type := HT_Ops.First (Container);
 426
 427    begin
 428       if Node = 0 then
 429          return No_Element;
 430       end if;
 431
 432       return (Node => Node);
 433    end First;
 434
 435    ----------
 436    -- Free --
 437    ----------
 438
 439    procedure Free (HT : in out Map; X : Count_Type) is
 440    begin
 441       HT.Nodes (X).Has_Element := False;
 442       HT_Ops.Free (HT, X);
 443    end Free;
 444
 445    ----------------------
 446    -- Generic_Allocate --
 447    ----------------------
 448
 449    procedure Generic_Allocate (HT : in out Map; Node : out Count_Type) is
 450
 451       procedure Allocate is
 452         new HT_Ops.Generic_Allocate (Set_Element);
 453
 454    begin
 455       Allocate (HT, Node);
 456       HT.Nodes (Node).Has_Element := True;
 457    end Generic_Allocate;
 458
 459    -----------------
 460    -- Has_Element --
 461    -----------------
 462
 463    function Has_Element (Container : Map; Position : Cursor) return Boolean is
 464    begin
 465       if Position.Node = 0 or else
 466         not Container.Nodes (Position.Node).Has_Element then
 467          return False;
 468       end if;
 469
 470       return True;
 471    end Has_Element;
 472
 473    ---------------
 474    -- Hash_Node --
 475    ---------------
 476
 477    function Hash_Node (Node : Node_Type) return Hash_Type is
 478    begin
 479       return Hash (Node.Key);
 480    end Hash_Node;
 481
 482    -------------
 483    -- Include --
 484    -------------
 485
 486    procedure Include
 487      (Container : in out Map;
 488       Key       : Key_Type;
 489       New_Item  : Element_Type)
 490    is
 491       Position : Cursor;
 492       Inserted : Boolean;
 493
 494    begin
 495       Insert (Container, Key, New_Item, Position, Inserted);
 496
 497       if not Inserted then
 498          if Container.Lock > 0 then
 499             raise Program_Error with
 500               "Include attempted to tamper with cursors (map is locked)";
 501          end if;
 502
 503          declare
 504             N : Node_Type renames Container.Nodes (Position.Node);
 505          begin
 506             N.Key := Key;
 507             N.Element := New_Item;
 508          end;
 509       end if;
 510    end Include;
 511
 512    ------------
 513    -- Insert --
 514    ------------
 515
 516    procedure Insert
 517      (Container : in out Map;
 518       Key       : Key_Type;
 519       Position  : out Cursor;
 520       Inserted  : out Boolean)
 521    is
 522       procedure Assign_Key (Node : in out Node_Type);
 523       pragma Inline (Assign_Key);
 524
 525       function New_Node return Count_Type;
 526       pragma Inline (New_Node);
 527
 528       procedure Local_Insert is
 529         new Key_Ops.Generic_Conditional_Insert (New_Node);
 530
 531       procedure Allocate is
 532         new Generic_Allocate (Assign_Key);
 533
 534       -----------------
 535       --  Assign_Key --
 536       -----------------
 537
 538       procedure Assign_Key (Node : in out Node_Type) is
 539       begin
 540          Node.Key := Key;
 541
 542          --  What is following commented out line doing here ???
 543          --  Node.Element := New_Item;
 544       end Assign_Key;
 545
 546       --------------
 547       -- New_Node --
 548       --------------
 549
 550       function New_Node return Count_Type is
 551          Result : Count_Type;
 552       begin
 553          Allocate (Container, Result);
 554          return Result;
 555       end New_Node;
 556
 557    --  Start of processing for Insert
 558
 559    begin
 560
 561       Local_Insert (Container, Key, Position.Node, Inserted);
 562    end Insert;
 563
 564    procedure Insert
 565      (Container : in out Map;
 566       Key       : Key_Type;
 567       New_Item  : Element_Type;
 568       Position  : out Cursor;
 569       Inserted  : out Boolean)
 570    is
 571       procedure Assign_Key (Node : in out Node_Type);
 572       pragma Inline (Assign_Key);
 573
 574       function New_Node return Count_Type;
 575       pragma Inline (New_Node);
 576
 577       procedure Local_Insert is
 578         new Key_Ops.Generic_Conditional_Insert (New_Node);
 579
 580       procedure Allocate is
 581         new Generic_Allocate (Assign_Key);
 582
 583       -----------------
 584       --  Assign_Key --
 585       -----------------
 586
 587       procedure Assign_Key (Node : in out Node_Type) is
 588       begin
 589          Node.Key := Key;
 590          Node.Element := New_Item;
 591       end Assign_Key;
 592
 593       --------------
 594       -- New_Node --
 595       --------------
 596
 597       function New_Node return Count_Type is
 598          Result : Count_Type;
 599       begin
 600          Allocate (Container, Result);
 601          return Result;
 602       end New_Node;
 603
 604    --  Start of processing for Insert
 605
 606    begin
 607       Local_Insert (Container, Key, Position.Node, Inserted);
 608    end Insert;
 609
 610    procedure Insert
 611      (Container : in out Map;
 612       Key       : Key_Type;
 613       New_Item  : Element_Type)
 614    is
 615       Position : Cursor;
 616       pragma Unreferenced (Position);
 617
 618       Inserted : Boolean;
 619
 620    begin
 621       Insert (Container, Key, New_Item, Position, Inserted);
 622
 623       if not Inserted then
 624          raise Constraint_Error with
 625            "attempt to insert key already in map";
 626       end if;
 627    end Insert;
 628
 629    --------------
 630    -- Is_Empty --
 631    --------------
 632
 633    function Is_Empty (Container : Map) return Boolean is
 634    begin
 635       return Length (Container) = 0;
 636    end Is_Empty;
 637
 638    -------------
 639    -- Iterate --
 640    -------------
 641
 642    procedure Iterate
 643      (Container : Map;
 644       Process   : not null
 645                     access procedure (Container : Map; Position : Cursor))
 646    is
 647       procedure Process_Node (Node : Count_Type);
 648       pragma Inline (Process_Node);
 649
 650       procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node);
 651
 652       ------------------
 653       -- Process_Node --
 654       ------------------
 655
 656       procedure Process_Node (Node : Count_Type) is
 657       begin
 658          Process (Container, (Node => Node));
 659       end Process_Node;
 660
 661       B : Natural renames Container'Unrestricted_Access.Busy;
 662
 663    --  Start of processing for Iterate
 664
 665    begin
 666       B := B + 1;
 667
 668       begin
 669          Local_Iterate (Container);
 670       exception
 671          when others =>
 672             B := B - 1;
 673             raise;
 674       end;
 675
 676       B := B - 1;
 677    end Iterate;
 678
 679    ---------
 680    -- Key --
 681    ---------
 682
 683    function Key (Container : Map; Position : Cursor) return Key_Type is
 684    begin
 685       if not Has_Element (Container, Position) then
 686          raise Constraint_Error with
 687            "Position cursor of function Key has no element";
 688       end if;
 689
 690       pragma Assert (Vet (Container, Position), "bad cursor in function Key");
 691
 692       return Container.Nodes (Position.Node).Key;
 693    end Key;
 694
 695    ----------
 696    -- Left --
 697    ----------
 698
 699    function Left (Container : Map; Position : Cursor) return Map is
 700       Curs : Cursor;
 701       C    : Map (Container.Capacity, Container.Modulus) :=
 702         Copy (Container, Container.Capacity);
 703       Node : Count_Type;
 704
 705    begin
 706       Curs := Position;
 707
 708       if Curs = No_Element then
 709          return C;
 710       end if;
 711
 712       if not Has_Element (Container, Curs) then
 713          raise Constraint_Error;
 714       end if;
 715
 716       while Curs.Node /= 0 loop
 717          Node := Curs.Node;
 718          Delete (C, Curs);
 719          Curs := Next (Container, (Node => Node));
 720       end loop;
 721
 722       return C;
 723    end Left;
 724
 725    ------------
 726    -- Length --
 727    ------------
 728
 729    function Length (Container : Map) return Count_Type is
 730    begin
 731       return Container.Length;
 732    end Length;
 733
 734    ----------
 735    -- Move --
 736    ----------
 737
 738    procedure Move
 739      (Target : in out Map;
 740       Source : in out Map)
 741    is
 742       NN   : HT_Types.Nodes_Type renames Source.Nodes;
 743       X, Y : Count_Type;
 744
 745    begin
 746       if Target'Address = Source'Address then
 747          return;
 748       end if;
 749
 750       if Target.Capacity < Length (Source) then
 751          raise Constraint_Error with  -- ???
 752            "Source length exceeds Target capacity";
 753       end if;
 754
 755       if Source.Busy > 0 then
 756          raise Program_Error with
 757            "attempt to tamper with cursors of Source (list is busy)";
 758       end if;
 759
 760       Clear (Target);
 761
 762       if Source.Length = 0 then
 763          return;
 764       end if;
 765
 766       X := HT_Ops.First (Source);
 767       while X /= 0 loop
 768          Insert (Target, NN (X).Key, NN (X).Element);  -- optimize???
 769
 770          Y := HT_Ops.Next (Source, X);
 771
 772          HT_Ops.Delete_Node_Sans_Free (Source, X);
 773          Free (Source, X);
 774
 775          X := Y;
 776       end loop;
 777    end Move;
 778
 779    ----------
 780    -- Next --
 781    ----------
 782
 783    function Next (Node : Node_Type) return Count_Type is
 784    begin
 785       return Node.Next;
 786    end Next;
 787
 788    function Next (Container : Map; Position : Cursor) return Cursor is
 789    begin
 790       if Position.Node = 0 then
 791          return No_Element;
 792       end if;
 793
 794       if not Has_Element (Container, Position) then
 795          raise Constraint_Error
 796            with "Position has no element";
 797       end if;
 798
 799       pragma Assert (Vet (Container, Position), "bad cursor in function Next");
 800
 801       declare
 802          Node : constant Count_Type := HT_Ops.Next (Container, Position.Node);
 803
 804       begin
 805          if Node = 0 then
 806             return No_Element;
 807          end if;
 808
 809          return (Node => Node);
 810       end;
 811    end Next;
 812
 813    procedure Next (Container : Map; Position : in out Cursor) is
 814    begin
 815       Position := Next (Container, Position);
 816    end Next;
 817
 818    -------------
 819    -- Overlap --
 820    -------------
 821
 822    function Overlap (Left, Right : Map) return Boolean is
 823       Left_Node  : Count_Type;
 824       Left_Nodes : Nodes_Type renames Left.Nodes;
 825
 826    begin
 827       if Length (Right) = 0 or Length (Left) = 0 then
 828          return False;
 829       end if;
 830
 831       if Left'Address = Right'Address then
 832          return True;
 833       end if;
 834
 835       Left_Node := First (Left).Node;
 836       while Left_Node /= 0 loop
 837          declare
 838             N : Node_Type renames Left_Nodes (Left_Node);
 839             E : Key_Type renames N.Key;
 840          begin
 841             if Find (Right, E).Node /= 0 then
 842                return True;
 843             end if;
 844          end;
 845
 846          Left_Node := HT_Ops.Next (Left, Left_Node);
 847       end loop;
 848
 849       return False;
 850    end Overlap;
 851
 852    -------------------
 853    -- Query_Element --
 854    -------------------
 855
 856    procedure Query_Element
 857      (Container : in out Map;
 858       Position  : Cursor;
 859       Process   : not null access
 860                     procedure (Key : Key_Type; Element : Element_Type))
 861    is
 862    begin
 863       if not Has_Element (Container, Position) then
 864          raise Constraint_Error with
 865            "Position cursor of Query_Element has no element";
 866       end if;
 867
 868       pragma Assert (Vet (Container, Position), "bad cursor in Query_Element");
 869
 870       declare
 871          N : Node_Type renames Container.Nodes (Position.Node);
 872          B : Natural renames Container.Busy;
 873          L : Natural renames Container.Lock;
 874
 875       begin
 876          B := B + 1;
 877          L := L + 1;
 878
 879          declare
 880             K : Key_Type renames N.Key;
 881             E : Element_Type renames N.Element;
 882          begin
 883             Process (K, E);
 884          exception
 885             when others =>
 886                L := L - 1;
 887                B := B - 1;
 888                raise;
 889          end;
 890
 891          L := L - 1;
 892          B := B - 1;
 893       end;
 894    end Query_Element;
 895
 896    ----------
 897    -- Read --
 898    ----------
 899
 900    procedure Read
 901      (Stream    : not null access Root_Stream_Type'Class;
 902       Container : out Map)
 903    is
 904       function Read_Node (Stream : not null access Root_Stream_Type'Class)
 905                           return Count_Type;
 906
 907       procedure Read_Nodes is
 908         new HT_Ops.Generic_Read (Read_Node);
 909
 910       ---------------
 911       -- Read_Node --
 912       ---------------
 913
 914       function Read_Node
 915         (Stream : not null access Root_Stream_Type'Class) return Count_Type
 916       is
 917          procedure Read_Element (Node : in out Node_Type);
 918          pragma Inline (Read_Element);
 919
 920          procedure Allocate is
 921            new Generic_Allocate (Read_Element);
 922
 923          procedure Read_Element (Node : in out Node_Type) is
 924          begin
 925             Element_Type'Read (Stream, Node.Element);
 926          end Read_Element;
 927
 928          Node : Count_Type;
 929
 930       --  Start of processing for Read_Node
 931
 932       begin
 933          Allocate (Container, Node);
 934          return Node;
 935       end Read_Node;
 936
 937    --  Start of processing for Read
 938
 939    begin
 940       Read_Nodes (Stream, Container);
 941    end Read;
 942
 943    procedure Read
 944      (Stream : not null access Root_Stream_Type'Class;
 945       Item   : out Cursor)
 946    is
 947    begin
 948       raise Program_Error with "attempt to stream set cursor";
 949    end Read;
 950
 951    -------------
 952    -- Replace --
 953    -------------
 954
 955    procedure Replace
 956      (Container : in out Map;
 957       Key       : Key_Type;
 958       New_Item  : Element_Type)
 959    is
 960       Node : constant Count_Type := Key_Ops.Find (Container, Key);
 961
 962    begin
 963       if Node = 0 then
 964          raise Constraint_Error with
 965            "attempt to replace key not in map";
 966       end if;
 967
 968       if Container.Lock > 0 then
 969          raise Program_Error with
 970            "Replace attempted to tamper with cursors (map is locked)";
 971       end if;
 972
 973       declare
 974          N : Node_Type renames Container.Nodes (Node);
 975       begin
 976          N.Key := Key;
 977          N.Element := New_Item;
 978       end;
 979    end Replace;
 980
 981    ---------------------
 982    -- Replace_Element --
 983    ---------------------
 984
 985    procedure Replace_Element
 986      (Container : in out Map;
 987       Position  : Cursor;
 988       New_Item  : Element_Type)
 989    is
 990    begin
 991       if not Has_Element (Container, Position) then
 992          raise Constraint_Error with
 993            "Position cursor of Replace_Element has no element";
 994       end if;
 995
 996       if Container.Lock > 0 then
 997          raise Program_Error with
 998            "Replace_Element attempted to tamper with cursors (map is locked)";
 999       end if;
1000
1001       pragma Assert (Vet (Container, Position),
1002                      "bad cursor in Replace_Element");
1003
1004       Container.Nodes (Position.Node).Element := New_Item;
1005    end Replace_Element;
1006
1007    ----------------------
1008    -- Reserve_Capacity --
1009    ----------------------
1010
1011    procedure Reserve_Capacity
1012      (Container : in out Map;
1013       Capacity  : Count_Type)
1014    is
1015    begin
1016       if Capacity > Container.Capacity then
1017          raise Capacity_Error with "requested capacity is too large";
1018       end if;
1019    end Reserve_Capacity;
1020
1021    -----------
1022    -- Right --
1023    -----------
1024
1025    function Right (Container : Map; Position : Cursor) return Map is
1026       Curs : Cursor := First (Container);
1027       C    : Map (Container.Capacity, Container.Modulus) :=
1028         Copy (Container, Container.Capacity);
1029       Node : Count_Type;
1030
1031    begin
1032       if Curs = No_Element then
1033          Clear (C);
1034          return C;
1035       end if;
1036
1037       if Position /= No_Element and not Has_Element (Container, Position) then
1038          raise Constraint_Error;
1039       end if;
1040
1041       while Curs.Node /= Position.Node loop
1042          Node := Curs.Node;
1043          Delete (C, Curs);
1044          Curs := Next (Container, (Node => Node));
1045       end loop;
1046
1047       return C;
1048    end Right;
1049
1050    --------------
1051    -- Set_Next --
1052    --------------
1053
1054    procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is
1055    begin
1056       Node.Next := Next;
1057    end Set_Next;
1058
1059    ------------------
1060    -- Strict_Equal --
1061    ------------------
1062
1063    function Strict_Equal (Left, Right : Map) return Boolean is
1064       CuL : Cursor := First (Left);
1065       CuR : Cursor := First (Right);
1066
1067    begin
1068       if Length (Left) /= Length (Right) then
1069          return False;
1070       end if;
1071
1072       while CuL.Node /= 0 or CuR.Node /= 0 loop
1073          if CuL.Node /= CuR.Node or else
1074            (Left.Nodes (CuL.Node).Element /=
1075               Right.Nodes (CuR.Node).Element or
1076               Left.Nodes (CuL.Node).Key /=
1077               Right.Nodes (CuR.Node).Key) then
1078             return False;
1079          end if;
1080
1081          CuL := Next (Left, CuL);
1082          CuR := Next (Right, CuR);
1083       end loop;
1084
1085       return True;
1086    end Strict_Equal;
1087
1088    --------------------
1089    -- Update_Element --
1090    --------------------
1091
1092    procedure Update_Element
1093      (Container : in out Map;
1094       Position  : Cursor;
1095       Process   : not null access procedure (Key     : Key_Type;
1096                                              Element : in out Element_Type))
1097    is
1098    begin
1099       if not Has_Element (Container, Position) then
1100          raise Constraint_Error with
1101            "Position cursor of Update_Element has no element";
1102       end if;
1103
1104       pragma Assert (Vet (Container, Position),
1105                      "bad cursor in Update_Element");
1106
1107       declare
1108          B  : Natural renames Container.Busy;
1109          L  : Natural renames Container.Lock;
1110
1111       begin
1112          B := B + 1;
1113          L := L + 1;
1114
1115          declare
1116             N : Node_Type renames Container.Nodes (Position.Node);
1117             K : Key_Type renames N.Key;
1118             E : Element_Type renames N.Element;
1119
1120          begin
1121             Process (K, E);
1122          exception
1123             when others =>
1124                L := L - 1;
1125                B := B - 1;
1126                raise;
1127          end;
1128
1129          L := L - 1;
1130          B := B - 1;
1131       end;
1132    end Update_Element;
1133
1134    ---------
1135    -- Vet --
1136    ---------
1137
1138    function Vet (Container : Map; Position : Cursor) return Boolean is
1139    begin
1140       if Position.Node = 0 then
1141          return True;
1142       end if;
1143
1144       declare
1145          X : Count_Type;
1146
1147       begin
1148          if Container.Length = 0 then
1149             return False;
1150          end if;
1151
1152          if Container.Capacity = 0 then
1153             return False;
1154          end if;
1155
1156          if Container.Buckets'Length = 0 then
1157             return False;
1158          end if;
1159
1160          if Position.Node > Container.Capacity then
1161             return False;
1162          end if;
1163
1164          if Container.Nodes (Position.Node).Next = Position.Node then
1165             return False;
1166          end if;
1167
1168          X := Container.Buckets
1169            (Key_Ops.Index (Container, Container.Nodes (Position.Node).Key));
1170
1171          for J in 1 .. Container.Length loop
1172             if X = Position.Node then
1173                return True;
1174             end if;
1175
1176             if X = 0 then
1177                return False;
1178             end if;
1179
1180             if X = Container.Nodes (X).Next then
1181
1182                --  Prevent unnecessary looping
1183
1184                return False;
1185             end if;
1186
1187             X := Container.Nodes (X).Next;
1188          end loop;
1189
1190          return False;
1191       end;
1192    end Vet;
1193
1194    -----------
1195    -- Write --
1196    -----------
1197
1198    procedure Write
1199      (Stream    : not null access Root_Stream_Type'Class;
1200       Container : Map)
1201    is
1202       procedure Write_Node
1203         (Stream : not null access Root_Stream_Type'Class;
1204          Node   : Node_Type);
1205       pragma Inline (Write_Node);
1206
1207       procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
1208
1209       ----------------
1210       -- Write_Node --
1211       ----------------
1212
1213       procedure Write_Node
1214         (Stream : not null access Root_Stream_Type'Class;
1215          Node   : Node_Type)
1216       is
1217       begin
1218          Key_Type'Write (Stream, Node.Key);
1219          Element_Type'Write (Stream, Node.Element);
1220       end Write_Node;
1221
1222    --  Start of processing for Write
1223
1224    begin
1225       Write_Nodes (Stream, Container);
1226    end Write;
1227
1228    procedure Write
1229      (Stream : not null access Root_Stream_Type'Class;
1230       Item   : Cursor)
1231    is
1232    begin
1233       raise Program_Error with "attempt to stream map cursor";
1234    end Write;
1235
1236 end Ada.Containers.Formal_Hashed_Maps;