gcc/ada/a-chtgbk.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --              ADA.CONTAINERS.HASH_TABLES.GENERIC_BOUNDED_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_Bounded_Keys is
  31
  32    -----------------------------
  33    -- Checked_Equivalent_Keys --
  34    -----------------------------
  35
  36    function Checked_Equivalent_Keys
  37      (HT   : aliased in out Hash_Table_Type'Class;
  38       Key  : Key_Type;
  39       Node : Count_Type) 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, HT.Nodes (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'Class;
  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 := HT.Buckets'First + 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'Class;
 103       Key : Key_Type;
 104       X   : out Count_Type)
 105    is
 106       Indx : Hash_Type;
 107       Prev : Count_Type;
 108
 109    begin
 110       if HT.Length = 0 then
 111          X := 0;
 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 = 0 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 (HT.Nodes (X));
 136          HT.Length := HT.Length - 1;
 137          return;
 138       end if;
 139
 140       loop
 141          Prev := X;
 142          X := Next (HT.Nodes (Prev));
 143
 144          if X = 0 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 (HT.Nodes (Prev), Next => Next (HT.Nodes (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  : Hash_Table_Type'Class;
 166       Key : Key_Type) return Count_Type
 167    is
 168       Indx : Hash_Type;
 169       Node : Count_Type;
 170
 171    begin
 172       if HT.Length = 0 then
 173          return 0;
 174       end if;
 175
 176       Indx := Checked_Index (HT'Unrestricted_Access.all, Key);
 177
 178       Node := HT.Buckets (Indx);
 179       while Node /= 0 loop
 180          if Checked_Equivalent_Keys
 181            (HT'Unrestricted_Access.all, Key, Node)
 182          then
 183             return Node;
 184          end if;
 185          Node := Next (HT.Nodes (Node));
 186       end loop;
 187
 188       return 0;
 189    end Find;
 190
 191    --------------------------------
 192    -- Generic_Conditional_Insert --
 193    --------------------------------
 194
 195    procedure Generic_Conditional_Insert
 196      (HT       : in out Hash_Table_Type'Class;
 197       Key      : Key_Type;
 198       Node     : out Count_Type;
 199       Inserted : out Boolean)
 200    is
 201       Indx : Hash_Type;
 202
 203    begin
 204       --  Per AI05-0022, the container implementation is required to detect
 205       --  element tampering by a generic actual subprogram.
 206
 207       if HT.Busy > 0 then
 208          raise Program_Error with
 209            "attempt to tamper with cursors (container is busy)";
 210       end if;
 211
 212       Indx := Checked_Index (HT, Key);
 213       Node := HT.Buckets (Indx);
 214
 215       if Node = 0 then
 216          if HT.Length = HT.Capacity then
 217             raise Capacity_Error with "no more capacity for insertion";
 218          end if;
 219
 220          Node := New_Node;
 221          Set_Next (HT.Nodes (Node), Next => 0);
 222
 223          Inserted := True;
 224
 225          HT.Buckets (Indx) := Node;
 226          HT.Length := HT.Length + 1;
 227
 228          return;
 229       end if;
 230
 231       loop
 232          if Checked_Equivalent_Keys (HT, Key, Node) then
 233             Inserted := False;
 234             return;
 235          end if;
 236
 237          Node := Next (HT.Nodes (Node));
 238
 239          exit when Node = 0;
 240       end loop;
 241
 242       if HT.Length = HT.Capacity then
 243          raise Capacity_Error with "no more capacity for insertion";
 244       end if;
 245
 246       Node := New_Node;
 247       Set_Next (HT.Nodes (Node), Next => HT.Buckets (Indx));
 248
 249       Inserted := True;
 250
 251       HT.Buckets (Indx) := Node;
 252       HT.Length := HT.Length + 1;
 253    end Generic_Conditional_Insert;
 254
 255    -----------------------------
 256    -- Generic_Replace_Element --
 257    -----------------------------
 258
 259    procedure Generic_Replace_Element
 260      (HT   : in out Hash_Table_Type'Class;
 261       Node : Count_Type;
 262       Key  : Key_Type)
 263    is
 264       pragma Assert (HT.Length > 0);
 265       pragma Assert (Node /= 0);
 266
 267       BB : Buckets_Type renames HT.Buckets;
 268       NN : Nodes_Type renames HT.Nodes;
 269
 270       Old_Indx : Hash_Type;
 271       New_Indx : constant Hash_Type := Checked_Index (HT, Key);
 272
 273       New_Bucket : Count_Type renames BB (New_Indx);
 274       N, M       : Count_Type;
 275
 276    begin
 277       --  Per AI05-0022, the container implementation is required to detect
 278       --  element tampering by a generic actual subprogram.
 279
 280       --  The following block appears to be vestigial -- this should be done
 281       --  using Checked_Index instead. Also, we might have to move the actual
 282       --  tampering checks to the top of the subprogram, in order to prevent
 283       --  infinite recursion when calling Hash. (This is similar to how Insert
 284       --  and Delete are implemented.) This implies that we will have to defer
 285       --  the computation of New_Index until after the tampering check. ???
 286
 287       declare
 288          B : Natural renames HT.Busy;
 289          L : Natural renames HT.Lock;
 290
 291       begin
 292          B := B + 1;
 293          L := L + 1;
 294
 295          Old_Indx := HT.Buckets'First + Hash (NN (Node)) mod HT.Buckets'Length;
 296
 297          B := B - 1;
 298          L := L - 1;
 299
 300       exception
 301          when others =>
 302             B := B - 1;
 303             L := L - 1;
 304
 305             raise;
 306       end;
 307
 308       --  Replace_Element is allowed to change a node's key to Key
 309       --  (generic formal operation Assign provides the mechanism), but
 310       --  only if Key is not already in the hash table. (In a unique-key
 311       --  hash table as this one, a key is mapped to exactly one node.)
 312
 313       if Checked_Equivalent_Keys (HT, Key, Node) then
 314          if HT.Lock > 0 then
 315             raise Program_Error with
 316               "attempt to tamper with elements (container is locked)";
 317          end if;
 318
 319          --  The new Key value is mapped to this same Node, so Node
 320          --  stays in the same bucket.
 321
 322          Assign (NN (Node), Key);
 323          return;
 324       end if;
 325
 326       --  Key is not equivalent to Node, so we now have to determine if it's
 327       --  equivalent to some other node in the hash table. This is the case
 328       --  irrespective of whether Key is in the same or a different bucket from
 329       --  Node.
 330
 331       N := New_Bucket;
 332       while N /= 0 loop
 333          if Checked_Equivalent_Keys (HT, Key, N) then
 334             pragma Assert (N /= Node);
 335             raise Program_Error with
 336               "attempt to replace existing element";
 337          end if;
 338
 339          N := Next (NN (N));
 340       end loop;
 341
 342       --  We have determined that Key is not already in the hash table, so
 343       --  the change is tentatively allowed. We now perform the standard
 344       --  checks to determine whether the hash table is locked (because you
 345       --  cannot change an element while it's in use by Query_Element or
 346       --  Update_Element), or if the container is busy (because moving a
 347       --  node to a different bucket would interfere with iteration).
 348
 349       if Old_Indx = New_Indx then
 350          --  The node is already in the bucket implied by Key. In this case
 351          --  we merely change its value without moving it.
 352
 353          if HT.Lock > 0 then
 354             raise Program_Error with
 355               "attempt to tamper with elements (container is locked)";
 356          end if;
 357
 358          Assign (NN (Node), Key);
 359          return;
 360       end if;
 361
 362       --  The node is a bucket different from the bucket implied by Key
 363
 364       if HT.Busy > 0 then
 365          raise Program_Error with
 366            "attempt to tamper with cursors (container is busy)";
 367       end if;
 368
 369       --  Do the assignment first, before moving the node, so that if Assign
 370       --  propagates an exception, then the hash table will not have been
 371       --  modified (except for any possible side-effect Assign had on Node).
 372
 373       Assign (NN (Node), Key);
 374
 375       --  Now we can safely remove the node from its current bucket
 376
 377       N := BB (Old_Indx);  -- get value of first node in old bucket
 378       pragma Assert (N /= 0);
 379
 380       if N = Node then  -- node is first node in its bucket
 381          BB (Old_Indx) := Next (NN (Node));
 382
 383       else
 384          pragma Assert (HT.Length > 1);
 385
 386          loop
 387             M := Next (NN (N));
 388             pragma Assert (M /= 0);
 389
 390             if M = Node then
 391                Set_Next (NN (N), Next => Next (NN (Node)));
 392                exit;
 393             end if;
 394
 395             N := M;
 396          end loop;
 397       end if;
 398
 399       --  Now we link the node into its new bucket (corresponding to Key)
 400
 401       Set_Next (NN (Node), Next => New_Bucket);
 402       New_Bucket := Node;
 403    end Generic_Replace_Element;
 404
 405    -----------
 406    -- Index --
 407    -----------
 408
 409    function Index
 410      (HT  : Hash_Table_Type'Class;
 411       Key : Key_Type) return Hash_Type is
 412    begin
 413       return HT.Buckets'First + Hash (Key) mod HT.Buckets'Length;
 414    end Index;
 415
 416 end Ada.Containers.Hash_Tables.Generic_Bounded_Keys;