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-2011, 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 :=
 411                Key_Ops.Find (Container, Key);
 412
 413    begin
 414       if Node = 0 then
 415          return No_Element;
 416       end if;
 417
 418       return (Node => Node);
 419    end Find;
 420
 421    -----------
 422    -- First --
 423    -----------
 424
 425    function First (Container : Map) return Cursor is
 426       Node : constant Count_Type := HT_Ops.First (Container);
 427
 428    begin
 429       if Node = 0 then
 430          return No_Element;
 431       end if;
 432
 433       return (Node => Node);
 434    end First;
 435
 436    ----------
 437    -- Free --
 438    ----------
 439
 440    procedure Free (HT : in out Map; X : Count_Type) is
 441    begin
 442       HT.Nodes (X).Has_Element := False;
 443       HT_Ops.Free (HT, X);
 444    end Free;
 445
 446    ----------------------
 447    -- Generic_Allocate --
 448    ----------------------
 449
 450    procedure Generic_Allocate (HT : in out Map; Node : out Count_Type) is
 451
 452       procedure Allocate is
 453         new HT_Ops.Generic_Allocate (Set_Element);
 454
 455    begin
 456       Allocate (HT, Node);
 457       HT.Nodes (Node).Has_Element := True;
 458    end Generic_Allocate;
 459
 460    -----------------
 461    -- Has_Element --
 462    -----------------
 463
 464    function Has_Element (Container : Map; Position : Cursor) return Boolean is
 465    begin
 466       if Position.Node = 0 or else
 467         not Container.Nodes (Position.Node).Has_Element then
 468          return False;
 469       end if;
 470
 471       return True;
 472    end Has_Element;
 473
 474    ---------------
 475    -- Hash_Node --
 476    ---------------
 477
 478    function Hash_Node (Node : Node_Type) return Hash_Type is
 479    begin
 480       return Hash (Node.Key);
 481    end Hash_Node;
 482
 483    -------------
 484    -- Include --
 485    -------------
 486
 487    procedure Include
 488      (Container : in out Map;
 489       Key       : Key_Type;
 490       New_Item  : Element_Type)
 491    is
 492       Position : Cursor;
 493       Inserted : Boolean;
 494
 495    begin
 496       Insert (Container, Key, New_Item, Position, Inserted);
 497
 498       if not Inserted then
 499          if Container.Lock > 0 then
 500             raise Program_Error with
 501               "Include attempted to tamper with cursors (map is locked)";
 502          end if;
 503
 504          declare
 505             N : Node_Type renames Container.Nodes (Position.Node);
 506          begin
 507             N.Key := Key;
 508             N.Element := New_Item;
 509          end;
 510       end if;
 511    end Include;
 512
 513    ------------
 514    -- Insert --
 515    ------------
 516
 517    procedure Insert
 518      (Container : in out Map;
 519       Key       : Key_Type;
 520       Position  : out Cursor;
 521       Inserted  : out Boolean)
 522    is
 523       procedure Assign_Key (Node : in out Node_Type);
 524       pragma Inline (Assign_Key);
 525
 526       function New_Node return Count_Type;
 527       pragma Inline (New_Node);
 528
 529       procedure Local_Insert is
 530         new Key_Ops.Generic_Conditional_Insert (New_Node);
 531
 532       procedure Allocate is
 533         new Generic_Allocate (Assign_Key);
 534
 535       -----------------
 536       --  Assign_Key --
 537       -----------------
 538
 539       procedure Assign_Key (Node : in out Node_Type) is
 540       begin
 541          Node.Key := Key;
 542
 543          --  What is following commented out line doing here ???
 544          --  Node.Element := New_Item;
 545       end Assign_Key;
 546
 547       --------------
 548       -- New_Node --
 549       --------------
 550
 551       function New_Node return Count_Type is
 552          Result : Count_Type;
 553       begin
 554          Allocate (Container, Result);
 555          return Result;
 556       end New_Node;
 557
 558    --  Start of processing for Insert
 559
 560    begin
 561
 562       Local_Insert (Container, Key, Position.Node, Inserted);
 563    end Insert;
 564
 565    procedure Insert
 566      (Container : in out Map;
 567       Key       : Key_Type;
 568       New_Item  : Element_Type;
 569       Position  : out Cursor;
 570       Inserted  : out Boolean)
 571    is
 572       procedure Assign_Key (Node : in out Node_Type);
 573       pragma Inline (Assign_Key);
 574
 575       function New_Node return Count_Type;
 576       pragma Inline (New_Node);
 577
 578       procedure Local_Insert is
 579         new Key_Ops.Generic_Conditional_Insert (New_Node);
 580
 581       procedure Allocate is
 582         new Generic_Allocate (Assign_Key);
 583
 584       -----------------
 585       --  Assign_Key --
 586       -----------------
 587
 588       procedure Assign_Key (Node : in out Node_Type) is
 589       begin
 590          Node.Key := Key;
 591          Node.Element := New_Item;
 592       end Assign_Key;
 593
 594       --------------
 595       -- New_Node --
 596       --------------
 597
 598       function New_Node return Count_Type is
 599          Result : Count_Type;
 600       begin
 601          Allocate (Container, Result);
 602          return Result;
 603       end New_Node;
 604
 605    --  Start of processing for Insert
 606
 607    begin
 608       Local_Insert (Container, Key, Position.Node, Inserted);
 609    end Insert;
 610
 611    procedure Insert
 612      (Container : in out Map;
 613       Key       : Key_Type;
 614       New_Item  : Element_Type)
 615    is
 616       Position : Cursor;
 617       pragma Unreferenced (Position);
 618
 619       Inserted : Boolean;
 620
 621    begin
 622       Insert (Container, Key, New_Item, Position, Inserted);
 623
 624       if not Inserted then
 625          raise Constraint_Error with
 626            "attempt to insert key already in map";
 627       end if;
 628    end Insert;
 629
 630    --------------
 631    -- Is_Empty --
 632    --------------
 633
 634    function Is_Empty (Container : Map) return Boolean is
 635    begin
 636       return Length (Container) = 0;
 637    end Is_Empty;
 638
 639    -------------
 640    -- Iterate --
 641    -------------
 642
 643    procedure Iterate
 644      (Container : Map;
 645       Process   : not null
 646                     access procedure (Container : Map; Position : Cursor))
 647    is
 648       procedure Process_Node (Node : Count_Type);
 649       pragma Inline (Process_Node);
 650
 651       procedure Local_Iterate is new HT_Ops.Generic_Iteration (Process_Node);
 652
 653       ------------------
 654       -- Process_Node --
 655       ------------------
 656
 657       procedure Process_Node (Node : Count_Type) is
 658       begin
 659          Process (Container, (Node => Node));
 660       end Process_Node;
 661
 662       B : Natural renames Container'Unrestricted_Access.Busy;
 663
 664    --  Start of processing for Iterate
 665
 666    begin
 667       B := B + 1;
 668
 669       begin
 670          Local_Iterate (Container);
 671       exception
 672          when others =>
 673             B := B - 1;
 674             raise;
 675       end;
 676
 677       B := B - 1;
 678    end Iterate;
 679
 680    ---------
 681    -- Key --
 682    ---------
 683
 684    function Key (Container : Map; Position : Cursor) return Key_Type is
 685    begin
 686       if not Has_Element (Container, Position) then
 687          raise Constraint_Error with
 688            "Position cursor of function Key has no element";
 689       end if;
 690
 691       pragma Assert (Vet (Container, Position), "bad cursor in function Key");
 692
 693       return Container.Nodes (Position.Node).Key;
 694    end Key;
 695
 696    ----------
 697    -- Left --
 698    ----------
 699
 700    function Left (Container : Map; Position : Cursor) return Map is
 701       Curs : Cursor;
 702       C    : Map (Container.Capacity, Container.Modulus) :=
 703                Copy (Container, Container.Capacity);
 704       Node : Count_Type;
 705
 706    begin
 707       Curs := Position;
 708
 709       if Curs = No_Element then
 710          return C;
 711       end if;
 712
 713       if not Has_Element (Container, Curs) then
 714          raise Constraint_Error;
 715       end if;
 716
 717       while Curs.Node /= 0 loop
 718          Node := Curs.Node;
 719          Delete (C, Curs);
 720          Curs := Next (Container, (Node => Node));
 721       end loop;
 722
 723       return C;
 724    end Left;
 725
 726    ------------
 727    -- Length --
 728    ------------
 729
 730    function Length (Container : Map) return Count_Type is
 731    begin
 732       return Container.Length;
 733    end Length;
 734
 735    ----------
 736    -- Move --
 737    ----------
 738
 739    procedure Move
 740      (Target : in out Map;
 741       Source : in out Map)
 742    is
 743       NN   : HT_Types.Nodes_Type renames Source.Nodes;
 744       X, Y : Count_Type;
 745
 746    begin
 747       if Target'Address = Source'Address then
 748          return;
 749       end if;
 750
 751       if Target.Capacity < Length (Source) then
 752          raise Constraint_Error with  -- ???
 753            "Source length exceeds Target capacity";
 754       end if;
 755
 756       if Source.Busy > 0 then
 757          raise Program_Error with
 758            "attempt to tamper with cursors of Source (list is busy)";
 759       end if;
 760
 761       Clear (Target);
 762
 763       if Source.Length = 0 then
 764          return;
 765       end if;
 766
 767       X := HT_Ops.First (Source);
 768       while X /= 0 loop
 769          Insert (Target, NN (X).Key, NN (X).Element);  -- optimize???
 770
 771          Y := HT_Ops.Next (Source, X);
 772
 773          HT_Ops.Delete_Node_Sans_Free (Source, X);
 774          Free (Source, X);
 775
 776          X := Y;
 777       end loop;
 778    end Move;
 779
 780    ----------
 781    -- Next --
 782    ----------
 783
 784    function Next (Node : Node_Type) return Count_Type is
 785    begin
 786       return Node.Next;
 787    end Next;
 788
 789    function Next (Container : Map; Position : Cursor) return Cursor is
 790    begin
 791       if Position.Node = 0 then
 792          return No_Element;
 793       end if;
 794
 795       if not Has_Element (Container, Position) then
 796          raise Constraint_Error
 797            with "Position has no element";
 798       end if;
 799
 800       pragma Assert (Vet (Container, Position), "bad cursor in function Next");
 801
 802       declare
 803          Node : constant Count_Type := HT_Ops.Next (Container, Position.Node);
 804
 805       begin
 806          if Node = 0 then
 807             return No_Element;
 808          end if;
 809
 810          return (Node => Node);
 811       end;
 812    end Next;
 813
 814    procedure Next (Container : Map; Position : in out Cursor) is
 815    begin
 816       Position := Next (Container, Position);
 817    end Next;
 818
 819    -------------
 820    -- Overlap --
 821    -------------
 822
 823    function Overlap (Left, Right : Map) return Boolean is
 824       Left_Node  : Count_Type;
 825       Left_Nodes : Nodes_Type renames Left.Nodes;
 826
 827    begin
 828       if Length (Right) = 0 or Length (Left) = 0 then
 829          return False;
 830       end if;
 831
 832       if Left'Address = Right'Address then
 833          return True;
 834       end if;
 835
 836       Left_Node := First (Left).Node;
 837       while Left_Node /= 0 loop
 838          declare
 839             N : Node_Type renames Left_Nodes (Left_Node);
 840             E : Key_Type renames N.Key;
 841          begin
 842             if Find (Right, E).Node /= 0 then
 843                return True;
 844             end if;
 845          end;
 846
 847          Left_Node := HT_Ops.Next (Left, Left_Node);
 848       end loop;
 849
 850       return False;
 851    end Overlap;
 852
 853    -------------------
 854    -- Query_Element --
 855    -------------------
 856
 857    procedure Query_Element
 858      (Container : in out Map;
 859       Position  : Cursor;
 860       Process   : not null access
 861                     procedure (Key : Key_Type; Element : Element_Type))
 862    is
 863    begin
 864       if not Has_Element (Container, Position) then
 865          raise Constraint_Error with
 866            "Position cursor of Query_Element has no element";
 867       end if;
 868
 869       pragma Assert (Vet (Container, Position), "bad cursor in Query_Element");
 870
 871       declare
 872          N : Node_Type renames Container.Nodes (Position.Node);
 873          B : Natural renames Container.Busy;
 874          L : Natural renames Container.Lock;
 875
 876       begin
 877          B := B + 1;
 878          L := L + 1;
 879
 880          declare
 881             K : Key_Type renames N.Key;
 882             E : Element_Type renames N.Element;
 883          begin
 884             Process (K, E);
 885          exception
 886             when others =>
 887                L := L - 1;
 888                B := B - 1;
 889                raise;
 890          end;
 891
 892          L := L - 1;
 893          B := B - 1;
 894       end;
 895    end Query_Element;
 896
 897    ----------
 898    -- Read --
 899    ----------
 900
 901    procedure Read
 902      (Stream    : not null access Root_Stream_Type'Class;
 903       Container : out Map)
 904    is
 905       function Read_Node (Stream : not null access Root_Stream_Type'Class)
 906                           return Count_Type;
 907
 908       procedure Read_Nodes is
 909         new HT_Ops.Generic_Read (Read_Node);
 910
 911       ---------------
 912       -- Read_Node --
 913       ---------------
 914
 915       function Read_Node
 916         (Stream : not null access Root_Stream_Type'Class) return Count_Type
 917       is
 918          procedure Read_Element (Node : in out Node_Type);
 919          pragma Inline (Read_Element);
 920
 921          procedure Allocate is
 922            new Generic_Allocate (Read_Element);
 923
 924          procedure Read_Element (Node : in out Node_Type) is
 925          begin
 926             Element_Type'Read (Stream, Node.Element);
 927          end Read_Element;
 928
 929          Node : Count_Type;
 930
 931       --  Start of processing for Read_Node
 932
 933       begin
 934          Allocate (Container, Node);
 935          return Node;
 936       end Read_Node;
 937
 938    --  Start of processing for Read
 939
 940    begin
 941       Read_Nodes (Stream, Container);
 942    end Read;
 943
 944    procedure Read
 945      (Stream : not null access Root_Stream_Type'Class;
 946       Item   : out Cursor)
 947    is
 948    begin
 949       raise Program_Error with "attempt to stream set cursor";
 950    end Read;
 951
 952    -------------
 953    -- Replace --
 954    -------------
 955
 956    procedure Replace
 957      (Container : in out Map;
 958       Key       : Key_Type;
 959       New_Item  : Element_Type)
 960    is
 961       Node : constant Count_Type := Key_Ops.Find (Container, Key);
 962
 963    begin
 964       if Node = 0 then
 965          raise Constraint_Error with
 966            "attempt to replace key not in map";
 967       end if;
 968
 969       if Container.Lock > 0 then
 970          raise Program_Error with
 971            "Replace attempted to tamper with cursors (map is locked)";
 972       end if;
 973
 974       declare
 975          N : Node_Type renames Container.Nodes (Node);
 976       begin
 977          N.Key := Key;
 978          N.Element := New_Item;
 979       end;
 980    end Replace;
 981
 982    ---------------------
 983    -- Replace_Element --
 984    ---------------------
 985
 986    procedure Replace_Element
 987      (Container : in out Map;
 988       Position  : Cursor;
 989       New_Item  : Element_Type)
 990    is
 991    begin
 992       if not Has_Element (Container, Position) then
 993          raise Constraint_Error with
 994            "Position cursor of Replace_Element has no element";
 995       end if;
 996
 997       if Container.Lock > 0 then
 998          raise Program_Error with
 999            "Replace_Element attempted to tamper with cursors (map is locked)";
1000       end if;
1001
1002       pragma Assert (Vet (Container, Position),
1003                      "bad cursor in Replace_Element");
1004
1005       Container.Nodes (Position.Node).Element := New_Item;
1006    end Replace_Element;
1007
1008    ----------------------
1009    -- Reserve_Capacity --
1010    ----------------------
1011
1012    procedure Reserve_Capacity
1013      (Container : in out Map;
1014       Capacity  : Count_Type)
1015    is
1016    begin
1017       if Capacity > Container.Capacity then
1018          raise Capacity_Error with "requested capacity is too large";
1019       end if;
1020    end Reserve_Capacity;
1021
1022    -----------
1023    -- Right --
1024    -----------
1025
1026    function Right (Container : Map; Position : Cursor) return Map is
1027       Curs : Cursor := First (Container);
1028       C    : Map (Container.Capacity, Container.Modulus) :=
1029                Copy (Container, Container.Capacity);
1030       Node : Count_Type;
1031
1032    begin
1033       if Curs = No_Element then
1034          Clear (C);
1035          return C;
1036       end if;
1037
1038       if Position /= No_Element and not Has_Element (Container, Position) then
1039          raise Constraint_Error;
1040       end if;
1041
1042       while Curs.Node /= Position.Node loop
1043          Node := Curs.Node;
1044          Delete (C, Curs);
1045          Curs := Next (Container, (Node => Node));
1046       end loop;
1047
1048       return C;
1049    end Right;
1050
1051    --------------
1052    -- Set_Next --
1053    --------------
1054
1055    procedure Set_Next (Node : in out Node_Type; Next : Count_Type) is
1056    begin
1057       Node.Next := Next;
1058    end Set_Next;
1059
1060    ------------------
1061    -- Strict_Equal --
1062    ------------------
1063
1064    function Strict_Equal (Left, Right : Map) return Boolean is
1065       CuL : Cursor := First (Left);
1066       CuR : Cursor := First (Right);
1067
1068    begin
1069       if Length (Left) /= Length (Right) then
1070          return False;
1071       end if;
1072
1073       while CuL.Node /= 0 or CuR.Node /= 0 loop
1074          if CuL.Node /= CuR.Node or else
1075            (Left.Nodes (CuL.Node).Element /=
1076               Right.Nodes (CuR.Node).Element or
1077               Left.Nodes (CuL.Node).Key /=
1078               Right.Nodes (CuR.Node).Key) then
1079             return False;
1080          end if;
1081
1082          CuL := Next (Left, CuL);
1083          CuR := Next (Right, CuR);
1084       end loop;
1085
1086       return True;
1087    end Strict_Equal;
1088
1089    --------------------
1090    -- Update_Element --
1091    --------------------
1092
1093    procedure Update_Element
1094      (Container : in out Map;
1095       Position  : Cursor;
1096       Process   : not null access procedure (Key     : Key_Type;
1097                                              Element : in out Element_Type))
1098    is
1099    begin
1100       if not Has_Element (Container, Position) then
1101          raise Constraint_Error with
1102            "Position cursor of Update_Element has no element";
1103       end if;
1104
1105       pragma Assert (Vet (Container, Position),
1106                      "bad cursor in Update_Element");
1107
1108       declare
1109          B  : Natural renames Container.Busy;
1110          L  : Natural renames Container.Lock;
1111
1112       begin
1113          B := B + 1;
1114          L := L + 1;
1115
1116          declare
1117             N : Node_Type renames Container.Nodes (Position.Node);
1118             K : Key_Type renames N.Key;
1119             E : Element_Type renames N.Element;
1120
1121          begin
1122             Process (K, E);
1123          exception
1124             when others =>
1125                L := L - 1;
1126                B := B - 1;
1127                raise;
1128          end;
1129
1130          L := L - 1;
1131          B := B - 1;
1132       end;
1133    end Update_Element;
1134
1135    ---------
1136    -- Vet --
1137    ---------
1138
1139    function Vet (Container : Map; Position : Cursor) return Boolean is
1140    begin
1141       if Position.Node = 0 then
1142          return True;
1143       end if;
1144
1145       declare
1146          X : Count_Type;
1147
1148       begin
1149          if Container.Length = 0 then
1150             return False;
1151          end if;
1152
1153          if Container.Capacity = 0 then
1154             return False;
1155          end if;
1156
1157          if Container.Buckets'Length = 0 then
1158             return False;
1159          end if;
1160
1161          if Position.Node > Container.Capacity then
1162             return False;
1163          end if;
1164
1165          if Container.Nodes (Position.Node).Next = Position.Node then
1166             return False;
1167          end if;
1168
1169          X := Container.Buckets
1170            (Key_Ops.Index (Container, Container.Nodes (Position.Node).Key));
1171
1172          for J in 1 .. Container.Length loop
1173             if X = Position.Node then
1174                return True;
1175             end if;
1176
1177             if X = 0 then
1178                return False;
1179             end if;
1180
1181             if X = Container.Nodes (X).Next then
1182
1183                --  Prevent unnecessary looping
1184
1185                return False;
1186             end if;
1187
1188             X := Container.Nodes (X).Next;
1189          end loop;
1190
1191          return False;
1192       end;
1193    end Vet;
1194
1195    -----------
1196    -- Write --
1197    -----------
1198
1199    procedure Write
1200      (Stream    : not null access Root_Stream_Type'Class;
1201       Container : Map)
1202    is
1203       procedure Write_Node
1204         (Stream : not null access Root_Stream_Type'Class;
1205          Node   : Node_Type);
1206       pragma Inline (Write_Node);
1207
1208       procedure Write_Nodes is new HT_Ops.Generic_Write (Write_Node);
1209
1210       ----------------
1211       -- Write_Node --
1212       ----------------
1213
1214       procedure Write_Node
1215         (Stream : not null access Root_Stream_Type'Class;
1216          Node   : Node_Type)
1217       is
1218       begin
1219          Key_Type'Write (Stream, Node.Key);
1220          Element_Type'Write (Stream, Node.Element);
1221       end Write_Node;
1222
1223    --  Start of processing for Write
1224
1225    begin
1226       Write_Nodes (Stream, Container);
1227    end Write;
1228
1229    procedure Write
1230      (Stream : not null access Root_Stream_Type'Class;
1231       Item   : Cursor)
1232    is
1233    begin
1234       raise Program_Error with "attempt to stream map cursor";
1235    end Write;
1236
1237 end Ada.Containers.Formal_Hashed_Maps;