gcc/ada/libgnat/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-2019, 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    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'Class;
  42       Key  : Key_Type;
  43       Node : Count_Type) return Boolean
  44    is
  45       Lock : With_Lock (HT.TC'Unrestricted_Access);
  46    begin
  47       return Equivalent_Keys (Key, HT.Nodes (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'Class;
  56       Key : Key_Type) return Hash_Type
  57    is
  58       Lock : With_Lock (HT.TC'Unrestricted_Access);
  59    begin
  60       return HT.Buckets'First + 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'Class;
  69       Key : Key_Type;
  70       X   : out Count_Type)
  71    is
  72       Indx : Hash_Type;
  73       Prev : Count_Type;
  74
  75    begin
  76       if HT.Length = 0 then
  77          X := 0;
  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 = 0 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 (HT.Nodes (X));
  96          HT.Length := HT.Length - 1;
  97          return;
  98       end if;
  99
 100       loop
 101          Prev := X;
 102          X := Next (HT.Nodes (Prev));
 103
 104          if X = 0 then
 105             return;
 106          end if;
 107
 108          if Checked_Equivalent_Keys (HT, Key, X) then
 109             TC_Check (HT.TC);
 110             Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (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  : Hash_Table_Type'Class;
 123       Key : Key_Type) return Count_Type
 124    is
 125       Indx : Hash_Type;
 126       Node : Count_Type;
 127
 128    begin
 129       if HT.Length = 0 then
 130          return 0;
 131       end if;
 132
 133       Indx := Checked_Index (HT'Unrestricted_Access.all, Key);
 134
 135       Node := HT.Buckets (Indx);
 136       while Node /= 0 loop
 137          if Checked_Equivalent_Keys
 138            (HT'Unrestricted_Access.all, Key, Node)
 139          then
 140             return Node;
 141          end if;
 142          Node := Next (HT.Nodes (Node));
 143       end loop;
 144
 145       return 0;
 146    end Find;
 147
 148    --------------------------------
 149    -- Generic_Conditional_Insert --
 150    --------------------------------
 151
 152    procedure Generic_Conditional_Insert
 153      (HT       : in out Hash_Table_Type'Class;
 154       Key      : Key_Type;
 155       Node     : out Count_Type;
 156       Inserted : out Boolean)
 157    is
 158       Indx : Hash_Type;
 159
 160    begin
 161       --  Per AI05-0022, the container implementation is required to detect
 162       --  element tampering by a generic actual subprogram.
 163
 164       TC_Check (HT.TC);
 165
 166       Indx := Checked_Index (HT, Key);
 167       Node := HT.Buckets (Indx);
 168
 169       if Node = 0 then
 170          if Checks and then HT.Length = HT.Capacity then
 171             raise Capacity_Error with "no more capacity for insertion";
 172          end if;
 173
 174          Node := New_Node;
 175          Set_Next (HT.Nodes (Node), Next => 0);
 176
 177          Inserted := True;
 178
 179          HT.Buckets (Indx) := Node;
 180          HT.Length := HT.Length + 1;
 181
 182          return;
 183       end if;
 184
 185       loop
 186          if Checked_Equivalent_Keys (HT, Key, Node) then
 187             Inserted := False;
 188             return;
 189          end if;
 190
 191          Node := Next (HT.Nodes (Node));
 192
 193          exit when Node = 0;
 194       end loop;
 195
 196       if Checks and then HT.Length = HT.Capacity then
 197          raise Capacity_Error with "no more capacity for insertion";
 198       end if;
 199
 200       Node := New_Node;
 201       Set_Next (HT.Nodes (Node), Next => HT.Buckets (Indx));
 202
 203       Inserted := True;
 204
 205       HT.Buckets (Indx) := Node;
 206       HT.Length := HT.Length + 1;
 207    end Generic_Conditional_Insert;
 208
 209    -----------------------------
 210    -- Generic_Replace_Element --
 211    -----------------------------
 212
 213    procedure Generic_Replace_Element
 214      (HT   : in out Hash_Table_Type'Class;
 215       Node : Count_Type;
 216       Key  : Key_Type)
 217    is
 218       pragma Assert (HT.Length > 0);
 219       pragma Assert (Node /= 0);
 220
 221       BB : Buckets_Type renames HT.Buckets;
 222       NN : Nodes_Type renames HT.Nodes;
 223
 224       Old_Indx : Hash_Type;
 225       New_Indx : constant Hash_Type := Checked_Index (HT, Key);
 226
 227       New_Bucket : Count_Type renames BB (New_Indx);
 228       N, M       : Count_Type;
 229
 230    begin
 231       --  Per AI05-0022, the container implementation is required to detect
 232       --  element tampering by a generic actual subprogram.
 233
 234       --  The following block appears to be vestigial -- this should be done
 235       --  using Checked_Index instead. Also, we might have to move the actual
 236       --  tampering checks to the top of the subprogram, in order to prevent
 237       --  infinite recursion when calling Hash. (This is similar to how Insert
 238       --  and Delete are implemented.) This implies that we will have to defer
 239       --  the computation of New_Index until after the tampering check. ???
 240
 241       declare
 242          Lock : With_Lock (HT.TC'Unrestricted_Access);
 243       begin
 244          Old_Indx := HT.Buckets'First + Hash (NN (Node)) mod HT.Buckets'Length;
 245       end;
 246
 247       --  Replace_Element is allowed to change a node's key to Key
 248       --  (generic formal operation Assign provides the mechanism), but
 249       --  only if Key is not already in the hash table. (In a unique-key
 250       --  hash table as this one, a key is mapped to exactly one node.)
 251
 252       if Checked_Equivalent_Keys (HT, Key, Node) then
 253          TE_Check (HT.TC);
 254
 255          --  The new Key value is mapped to this same Node, so Node
 256          --  stays in the same bucket.
 257
 258          Assign (NN (Node), Key);
 259          return;
 260       end if;
 261
 262       --  Key is not equivalent to Node, so we now have to determine if it's
 263       --  equivalent to some other node in the hash table. This is the case
 264       --  irrespective of whether Key is in the same or a different bucket from
 265       --  Node.
 266
 267       N := New_Bucket;
 268       while N /= 0 loop
 269          if Checks and then Checked_Equivalent_Keys (HT, Key, N) then
 270             pragma Assert (N /= Node);
 271             raise Program_Error with
 272               "attempt to replace existing element";
 273          end if;
 274
 275          N := Next (NN (N));
 276       end loop;
 277
 278       --  We have determined that Key is not already in the hash table, so
 279       --  the change is tentatively allowed. We now perform the standard
 280       --  checks to determine whether the hash table is locked (because you
 281       --  cannot change an element while it's in use by Query_Element or
 282       --  Update_Element), or if the container is busy (because moving a
 283       --  node to a different bucket would interfere with iteration).
 284
 285       if Old_Indx = New_Indx then
 286          --  The node is already in the bucket implied by Key. In this case
 287          --  we merely change its value without moving it.
 288
 289          TE_Check (HT.TC);
 290
 291          Assign (NN (Node), Key);
 292          return;
 293       end if;
 294
 295       --  The node is a bucket different from the bucket implied by Key
 296
 297       TC_Check (HT.TC);
 298
 299       --  Do the assignment first, before moving the node, so that if Assign
 300       --  propagates an exception, then the hash table will not have been
 301       --  modified (except for any possible side-effect Assign had on Node).
 302
 303       Assign (NN (Node), Key);
 304
 305       --  Now we can safely remove the node from its current bucket
 306
 307       N := BB (Old_Indx);  -- get value of first node in old bucket
 308       pragma Assert (N /= 0);
 309
 310       if N = Node then  -- node is first node in its bucket
 311          BB (Old_Indx) := Next (NN (Node));
 312
 313       else
 314          pragma Assert (HT.Length > 1);
 315
 316          loop
 317             M := Next (NN (N));
 318             pragma Assert (M /= 0);
 319
 320             if M = Node then
 321                Set_Next (NN (N), Next => Next (NN (Node)));
 322                exit;
 323             end if;
 324
 325             N := M;
 326          end loop;
 327       end if;
 328
 329       --  Now we link the node into its new bucket (corresponding to Key)
 330
 331       Set_Next (NN (Node), Next => New_Bucket);
 332       New_Bucket := Node;
 333    end Generic_Replace_Element;
 334
 335    -----------
 336    -- Index --
 337    -----------
 338
 339    function Index
 340      (HT  : Hash_Table_Type'Class;
 341       Key : Key_Type) return Hash_Type is
 342    begin
 343       return HT.Buckets'First + Hash (Key) mod HT.Buckets'Length;
 344    end Index;
 345
 346 end Ada.Containers.Hash_Tables.Generic_Bounded_Keys;