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