gcc/ada/libgnat/a-chtgfk.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --               ADA.CONTAINERS.HASH_TABLES.GENERIC_FORMAL_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_Formal_Keys is
  31
  32    Checks : constant Boolean := Container_Checks'Enabled;
  33
  34    --------------------------
  35    -- Delete_Key_Sans_Free --
  36    --------------------------
  37
  38    procedure Delete_Key_Sans_Free
  39      (HT  : in out Hash_Table_Type;
  40       Key : Key_Type;
  41       X   : out Count_Type)
  42    is
  43       Indx : Hash_Type;
  44       Prev : Count_Type;
  45
  46    begin
  47       if HT.Length = 0 then
  48          X := 0;
  49          return;
  50       end if;
  51
  52       Indx := Index (HT, Key);
  53       X := HT.Buckets (Indx);
  54
  55       if X = 0 then
  56          return;
  57       end if;
  58
  59       if Equivalent_Keys (Key, HT.Nodes (X)) then
  60          HT.Buckets (Indx) := Next (HT.Nodes (X));
  61          HT.Length := HT.Length - 1;
  62          return;
  63       end if;
  64
  65       loop
  66          Prev := X;
  67          X := Next (HT.Nodes (Prev));
  68
  69          if X = 0 then
  70             return;
  71          end if;
  72
  73          if Equivalent_Keys (Key, HT.Nodes (X)) then
  74             Set_Next (HT.Nodes (Prev), Next => Next (HT.Nodes (X)));
  75             HT.Length := HT.Length - 1;
  76             return;
  77          end if;
  78       end loop;
  79    end Delete_Key_Sans_Free;
  80
  81    ----------
  82    -- Find --
  83    ----------
  84
  85    function Find
  86      (HT  : Hash_Table_Type;
  87       Key : Key_Type) return Count_Type
  88    is
  89       Indx : Hash_Type;
  90       Node : Count_Type;
  91
  92    begin
  93       if HT.Length = 0 then
  94          return 0;
  95       end if;
  96
  97       Indx := Index (HT, Key);
  98
  99       Node := HT.Buckets (Indx);
 100       while Node /= 0 loop
 101          if Equivalent_Keys (Key, HT.Nodes (Node)) then
 102             return Node;
 103          end if;
 104          Node := Next (HT.Nodes (Node));
 105       end loop;
 106
 107       return 0;
 108    end Find;
 109
 110    --------------------------------
 111    -- Generic_Conditional_Insert --
 112    --------------------------------
 113
 114    procedure Generic_Conditional_Insert
 115      (HT       : in out Hash_Table_Type;
 116       Key      : Key_Type;
 117       Node     : out Count_Type;
 118       Inserted : out Boolean)
 119    is
 120       Indx : Hash_Type;
 121
 122    begin
 123       Indx := Index (HT, Key);
 124       Node := HT.Buckets (Indx);
 125
 126       if Node = 0 then
 127          if Checks and then HT.Length = HT.Capacity then
 128             raise Capacity_Error with "no more capacity for insertion";
 129          end if;
 130
 131          New_Node (HT, Node);
 132          Set_Next (HT.Nodes (Node), Next => 0);
 133
 134          Inserted := True;
 135
 136          HT.Buckets (Indx) := Node;
 137          HT.Length := HT.Length + 1;
 138
 139          return;
 140       end if;
 141
 142       loop
 143          if Equivalent_Keys (Key, HT.Nodes (Node)) then
 144             Inserted := False;
 145             return;
 146          end if;
 147
 148          Node := Next (HT.Nodes (Node));
 149
 150          exit when Node = 0;
 151       end loop;
 152
 153       if Checks and then HT.Length = HT.Capacity then
 154          raise Capacity_Error with "no more capacity for insertion";
 155       end if;
 156
 157       New_Node (HT, Node);
 158       Set_Next (HT.Nodes (Node), Next => HT.Buckets (Indx));
 159
 160       Inserted := True;
 161
 162       HT.Buckets (Indx) := Node;
 163       HT.Length := HT.Length + 1;
 164    end Generic_Conditional_Insert;
 165
 166    -----------------------------
 167    -- Generic_Replace_Element --
 168    -----------------------------
 169
 170    procedure Generic_Replace_Element
 171      (HT   : in out Hash_Table_Type;
 172       Node : Count_Type;
 173       Key  : Key_Type)
 174    is
 175       pragma Assert (HT.Length > 0);
 176       pragma Assert (Node /= 0);
 177
 178       BB : Buckets_Type renames HT.Buckets;
 179       NN : Nodes_Type renames HT.Nodes;
 180
 181       Old_Indx : Hash_Type;
 182       New_Indx : constant Hash_Type := Index (HT, Key);
 183
 184       New_Bucket : Count_Type renames BB (New_Indx);
 185       N, M       : Count_Type;
 186
 187    begin
 188       Old_Indx := HT.Buckets'First + Hash (NN (Node)) mod HT.Buckets'Length;
 189
 190       --  Replace_Element is allowed to change a node's key to Key
 191       --  (generic formal operation Assign provides the mechanism), but
 192       --  only if Key is not already in the hash table. (In a unique-key
 193       --  hash table as this one, a key is mapped to exactly one node.)
 194
 195       if Equivalent_Keys (Key, NN (Node)) then
 196          --  The new Key value is mapped to this same Node, so Node
 197          --  stays in the same bucket.
 198
 199          Assign (NN (Node), Key);
 200          return;
 201       end if;
 202
 203       --  Key is not equivalent to Node, so we now have to determine if it's
 204       --  equivalent to some other node in the hash table. This is the case
 205       --  irrespective of whether Key is in the same or a different bucket from
 206       --  Node.
 207
 208       N := New_Bucket;
 209       while N /= 0 loop
 210          if Checks and then Equivalent_Keys (Key, NN (N)) then
 211             pragma Assert (N /= Node);
 212             raise Program_Error with
 213               "attempt to replace existing element";
 214          end if;
 215
 216          N := Next (NN (N));
 217       end loop;
 218
 219       --  We have determined that Key is not already in the hash table, so
 220       --  the change is allowed.
 221
 222       if Old_Indx = New_Indx then
 223          --  The node is already in the bucket implied by Key. In this case
 224          --  we merely change its value without moving it.
 225
 226          Assign (NN (Node), Key);
 227          return;
 228       end if;
 229
 230       --  The node is in a bucket different from the bucket implied by Key.
 231       --  Do the assignment first, before moving the node, so that if Assign
 232       --  propagates an exception, then the hash table will not have been
 233       --  modified (except for any possible side-effect Assign had on Node).
 234
 235       Assign (NN (Node), Key);
 236
 237       --  Now we can safely remove the node from its current bucket
 238
 239       N := BB (Old_Indx);  -- get value of first node in old bucket
 240       pragma Assert (N /= 0);
 241
 242       if N = Node then  -- node is first node in its bucket
 243          BB (Old_Indx) := Next (NN (Node));
 244
 245       else
 246          pragma Assert (HT.Length > 1);
 247
 248          loop
 249             M := Next (NN (N));
 250             pragma Assert (M /= 0);
 251
 252             if M = Node then
 253                Set_Next (NN (N), Next => Next (NN (Node)));
 254                exit;
 255             end if;
 256
 257             N := M;
 258          end loop;
 259       end if;
 260
 261       --  Now we link the node into its new bucket (corresponding to Key)
 262
 263       Set_Next (NN (Node), Next => New_Bucket);
 264       New_Bucket := Node;
 265    end Generic_Replace_Element;
 266
 267    -----------
 268    -- Index --
 269    -----------
 270
 271    function Index
 272      (HT  : Hash_Table_Type;
 273       Key : Key_Type) return Hash_Type is
 274    begin
 275       return HT.Buckets'First + Hash (Key) mod HT.Buckets'Length;
 276    end Index;
 277
 278 end Ada.Containers.Hash_Tables.Generic_Formal_Keys;