gcc/ada/a-chtgke.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                 ADA.CONTAINERS.HASH_TABLES.GENERIC_KEYS                  --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 2004-2013, 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 package body Ada.Containers.Hash_Tables.Generic_Keys is
  31
  32    -----------------------------
  33    -- Checked_Equivalent_Keys --
  34    -----------------------------
  35
  36    function Checked_Equivalent_Keys
  37      (HT   : aliased in out Hash_Table_Type;
  38       Key  : Key_Type;
  39       Node : Node_Access) return Boolean
  40    is
  41       Result : Boolean;
  42
  43       B : Natural renames HT.Busy;
  44       L : Natural renames HT.Lock;
  45
  46    begin
  47       B := B + 1;
  48       L := L + 1;
  49
  50       Result := Equivalent_Keys (Key, Node);
  51
  52       B := B - 1;
  53       L := L - 1;
  54
  55       return Result;
  56
  57    exception
  58       when others =>
  59          B := B - 1;
  60          L := L - 1;
  61
  62          raise;
  63    end Checked_Equivalent_Keys;
  64
  65    -------------------
  66    -- Checked_Index --
  67    -------------------
  68
  69    function Checked_Index
  70      (HT  : aliased in out Hash_Table_Type;
  71       Key : Key_Type) return Hash_Type
  72    is
  73       Result : Hash_Type;
  74
  75       B : Natural renames HT.Busy;
  76       L : Natural renames HT.Lock;
  77
  78    begin
  79       B := B + 1;
  80       L := L + 1;
  81
  82       Result := Hash (Key) mod HT.Buckets'Length;
  83
  84       B := B - 1;
  85       L := L - 1;
  86
  87       return Result;
  88
  89    exception
  90       when others =>
  91          B := B - 1;
  92          L := L - 1;
  93
  94          raise;
  95    end Checked_Index;
  96
  97    --------------------------
  98    -- Delete_Key_Sans_Free --
  99    --------------------------
 100
 101    procedure Delete_Key_Sans_Free
 102      (HT  : in out Hash_Table_Type;
 103       Key : Key_Type;
 104       X   : out Node_Access)
 105    is
 106       Indx : Hash_Type;
 107       Prev : Node_Access;
 108
 109    begin
 110       if HT.Length = 0 then
 111          X := null;
 112          return;
 113       end if;
 114
 115       --  Per AI05-0022, the container implementation is required to detect
 116       --  element tampering by a generic actual subprogram.
 117
 118       if HT.Busy > 0 then
 119          raise Program_Error with
 120            "attempt to tamper with cursors (container is busy)";
 121       end if;
 122
 123       Indx := Checked_Index (HT, Key);
 124       X := HT.Buckets (Indx);
 125
 126       if X = null then
 127          return;
 128       end if;
 129
 130       if Checked_Equivalent_Keys (HT, Key, X) then
 131          if HT.Busy > 0 then
 132             raise Program_Error with
 133               "attempt to tamper with cursors (container is busy)";
 134          end if;
 135          HT.Buckets (Indx) := Next (X);
 136          HT.Length := HT.Length - 1;
 137          return;
 138       end if;
 139
 140       loop
 141          Prev := X;
 142          X := Next (Prev);
 143
 144          if X = null then
 145             return;
 146          end if;
 147
 148          if Checked_Equivalent_Keys (HT, Key, X) then
 149             if HT.Busy > 0 then
 150                raise Program_Error with
 151                  "attempt to tamper with cursors (container is busy)";
 152             end if;
 153             Set_Next (Node => Prev, Next => Next (X));
 154             HT.Length := HT.Length - 1;
 155             return;
 156          end if;
 157       end loop;
 158    end Delete_Key_Sans_Free;
 159
 160    ----------
 161    -- Find --
 162    ----------
 163
 164    function Find
 165      (HT  : aliased in out Hash_Table_Type;
 166       Key : Key_Type) return Node_Access
 167    is
 168       Indx : Hash_Type;
 169       Node : Node_Access;
 170
 171    begin
 172       if HT.Length = 0 then
 173          return null;
 174       end if;
 175
 176       Indx := Checked_Index (HT, Key);
 177
 178       Node := HT.Buckets (Indx);
 179       while Node /= null loop
 180          if Checked_Equivalent_Keys (HT, Key, Node) then
 181             return Node;
 182          end if;
 183          Node := Next (Node);
 184       end loop;
 185
 186       return null;
 187    end Find;
 188
 189    --------------------------------
 190    -- Generic_Conditional_Insert --
 191    --------------------------------
 192
 193    procedure Generic_Conditional_Insert
 194      (HT       : in out Hash_Table_Type;
 195       Key      : Key_Type;
 196       Node     : out Node_Access;
 197       Inserted : out Boolean)
 198    is
 199       Indx : Hash_Type;
 200
 201    begin
 202       --  Per AI05-0022, the container implementation is required to detect
 203       --  element tampering by a generic actual subprogram.
 204
 205       if HT.Busy > 0 then
 206          raise Program_Error with
 207            "attempt to tamper with cursors (container is busy)";
 208       end if;
 209
 210       Indx := Checked_Index (HT, Key);
 211       Node := HT.Buckets (Indx);
 212
 213       if Node = null then
 214          if HT.Length = Count_Type'Last then
 215             raise Constraint_Error;
 216          end if;
 217
 218          Node := New_Node (Next => null);
 219          Inserted := True;
 220
 221          HT.Buckets (Indx) := Node;
 222          HT.Length := HT.Length + 1;
 223
 224          return;
 225       end if;
 226
 227       loop
 228          if Checked_Equivalent_Keys (HT, Key, Node) then
 229             Inserted := False;
 230             return;
 231          end if;
 232
 233          Node := Next (Node);
 234
 235          exit when Node = null;
 236       end loop;
 237
 238       if HT.Length = Count_Type'Last then
 239          raise Constraint_Error;
 240       end if;
 241
 242       Node := New_Node (Next => HT.Buckets (Indx));
 243       Inserted := True;
 244
 245       HT.Buckets (Indx) := Node;
 246       HT.Length := HT.Length + 1;
 247    end Generic_Conditional_Insert;
 248
 249    -----------------------------
 250    -- Generic_Replace_Element --
 251    -----------------------------
 252
 253    procedure Generic_Replace_Element
 254      (HT   : in out Hash_Table_Type;
 255       Node : Node_Access;
 256       Key  : Key_Type)
 257    is
 258       pragma Assert (HT.Length > 0);
 259       pragma Assert (Node /= null);
 260
 261       Old_Indx : Hash_Type;
 262       New_Indx : constant Hash_Type := Checked_Index (HT, Key);
 263
 264       New_Bucket : Node_Access renames HT.Buckets (New_Indx);
 265       N, M       : Node_Access;
 266
 267    begin
 268       --  Per AI05-0022, the container implementation is required to detect
 269       --  element tampering by a generic actual subprogram.
 270
 271       declare
 272          B : Natural renames HT.Busy;
 273          L : Natural renames HT.Lock;
 274
 275       begin
 276          B := B + 1;
 277          L := L + 1;
 278
 279          Old_Indx := Hash (Node) mod HT.Buckets'Length;
 280
 281          B := B - 1;
 282          L := L - 1;
 283
 284       exception
 285          when others =>
 286             B := B - 1;
 287             L := L - 1;
 288
 289             raise;
 290       end;
 291
 292       if Checked_Equivalent_Keys (HT, Key, Node) then
 293          if HT.Lock > 0 then
 294             raise Program_Error with
 295               "attempt to tamper with elements (container is locked)";
 296          end if;
 297
 298          --  We can change a node's key to Key (that's what Assign is for), but
 299          --  only if Key is not already in the hash table. (In a unique-key
 300          --  hash table as this one a key is mapped to exactly one node only.)
 301          --  The exception is when Key is mapped to Node, in which case the
 302          --  change is allowed.
 303
 304          Assign (Node, Key);
 305          return;
 306       end if;
 307
 308       --  Key is not equivalent to Node, so we now have to determine if it's
 309       --  equivalent to some other node in the hash table. This is the case
 310       --  irrespective of whether Key is in the same or a different bucket from
 311       --  Node.
 312
 313       N := New_Bucket;
 314       while N /= null loop
 315          if Checked_Equivalent_Keys (HT, Key, N) then
 316             pragma Assert (N /= Node);
 317             raise Program_Error with
 318               "attempt to replace existing element";
 319          end if;
 320
 321          N := Next (N);
 322       end loop;
 323
 324       --  We have determined that Key is not already in the hash table, so
 325       --  the change is tentatively allowed. We now perform the standard
 326       --  checks to determine whether the hash table is locked (because you
 327       --  cannot change an element while it's in use by Query_Element or
 328       --  Update_Element), or if the container is busy (because moving a
 329       --  node to a different bucket would interfere with iteration).
 330
 331       if Old_Indx = New_Indx then
 332          --  The node is already in the bucket implied by Key. In this case
 333          --  we merely change its value without moving it.
 334
 335          if HT.Lock > 0 then
 336             raise Program_Error with
 337               "attempt to tamper with elements (container is locked)";
 338          end if;
 339
 340          Assign (Node, Key);
 341          return;
 342       end if;
 343
 344       --  The node is a bucket different from the bucket implied by Key
 345
 346       if HT.Busy > 0 then
 347          raise Program_Error with
 348            "attempt to tamper with cursors (container is busy)";
 349       end if;
 350
 351       --  Do the assignment first, before moving the node, so that if Assign
 352       --  propagates an exception, then the hash table will not have been
 353       --  modified (except for any possible side-effect Assign had on Node).
 354
 355       Assign (Node, Key);
 356
 357       --  Now we can safely remove the node from its current bucket
 358
 359       N := HT.Buckets (Old_Indx);
 360       pragma Assert (N /= null);
 361
 362       if N = Node then
 363          HT.Buckets (Old_Indx) := Next (Node);
 364
 365       else
 366          pragma Assert (HT.Length > 1);
 367
 368          loop
 369             M := Next (N);
 370             pragma Assert (M /= null);
 371
 372             if M = Node then
 373                Set_Next (Node => N, Next => Next (Node));
 374                exit;
 375             end if;
 376
 377             N := M;
 378          end loop;
 379       end if;
 380
 381       --  Now we link the node into its new bucket (corresponding to Key)
 382
 383       Set_Next (Node => Node, Next => New_Bucket);
 384       New_Bucket := Node;
 385    end Generic_Replace_Element;
 386
 387    -----------
 388    -- Index --
 389    -----------
 390
 391    function Index
 392      (HT  : Hash_Table_Type;
 393       Key : Key_Type) return Hash_Type
 394    is
 395    begin
 396       return Hash (Key) mod HT.Buckets'Length;
 397    end Index;
 398
 399 end Ada.Containers.Hash_Tables.Generic_Keys;