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