gcc/ada/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-2008, 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 2,  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.  See the GNU General Public License --
  17 -- for  more details.  You should have  received  a copy of the GNU General --
  18 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  19 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, USA.                                              --
  21 --                                                                          --
  22 -- As a special exception,  if other files  instantiate  generics from this --
  23 -- unit, or you link  this unit with other files  to produce an executable, --
  24 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  25 -- covered  by the  GNU  General  Public  License.  This exception does not --
  26 -- however invalidate  any other reasons why  the executable file  might be --
  27 -- covered by the  GNU Public License.                                      --
  28 --                                                                          --
  29 -- This unit was originally developed by Matthew J Heaney.                  --
  30 ------------------------------------------------------------------------------
  31
  32 package body Ada.Containers.Hash_Tables.Generic_Keys is
  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 Node_Access)
  42    is
  43       Indx : Hash_Type;
  44       Prev : Node_Access;
  45
  46    begin
  47       if HT.Length = 0 then
  48          X := null;
  49          return;
  50       end if;
  51
  52       Indx := Index (HT, Key);
  53       X := HT.Buckets (Indx);
  54
  55       if X = null then
  56          return;
  57       end if;
  58
  59       if Equivalent_Keys (Key, X) then
  60          if HT.Busy > 0 then
  61             raise Program_Error with
  62               "attempt to tamper with elements (container is busy)";
  63          end if;
  64          HT.Buckets (Indx) := Next (X);
  65          HT.Length := HT.Length - 1;
  66          return;
  67       end if;
  68
  69       loop
  70          Prev := X;
  71          X := Next (Prev);
  72
  73          if X = null then
  74             return;
  75          end if;
  76
  77          if Equivalent_Keys (Key, X) then
  78             if HT.Busy > 0 then
  79                raise Program_Error with
  80                  "attempt to tamper with elements (container is busy)";
  81             end if;
  82             Set_Next (Node => Prev, Next => Next (X));
  83             HT.Length := HT.Length - 1;
  84             return;
  85          end if;
  86       end loop;
  87    end Delete_Key_Sans_Free;
  88
  89    ----------
  90    -- Find --
  91    ----------
  92
  93    function Find
  94      (HT  : Hash_Table_Type;
  95       Key : Key_Type) return Node_Access is
  96
  97       Indx : Hash_Type;
  98       Node : Node_Access;
  99
 100    begin
 101       if HT.Length = 0 then
 102          return null;
 103       end if;
 104
 105       Indx := Index (HT, Key);
 106
 107       Node := HT.Buckets (Indx);
 108       while Node /= null loop
 109          if Equivalent_Keys (Key, Node) then
 110             return Node;
 111          end if;
 112          Node := Next (Node);
 113       end loop;
 114
 115       return null;
 116    end Find;
 117
 118    --------------------------------
 119    -- Generic_Conditional_Insert --
 120    --------------------------------
 121
 122    procedure Generic_Conditional_Insert
 123      (HT       : in out Hash_Table_Type;
 124       Key      : Key_Type;
 125       Node     : out Node_Access;
 126       Inserted : out Boolean)
 127    is
 128       Indx : constant Hash_Type := Index (HT, Key);
 129       B    : Node_Access renames HT.Buckets (Indx);
 130
 131    begin
 132       if B = null then
 133          if HT.Busy > 0 then
 134             raise Program_Error with
 135               "attempt to tamper with elements (container is busy)";
 136          end if;
 137
 138          if HT.Length = Count_Type'Last then
 139             raise Constraint_Error;
 140          end if;
 141
 142          Node := New_Node (Next => null);
 143          Inserted := True;
 144
 145          B := Node;
 146          HT.Length := HT.Length + 1;
 147
 148          return;
 149       end if;
 150
 151       Node := B;
 152       loop
 153          if Equivalent_Keys (Key, Node) then
 154             Inserted := False;
 155             return;
 156          end if;
 157
 158          Node := Next (Node);
 159
 160          exit when Node = null;
 161       end loop;
 162
 163       if HT.Busy > 0 then
 164          raise Program_Error with
 165            "attempt to tamper with elements (container is busy)";
 166       end if;
 167
 168       if HT.Length = Count_Type'Last then
 169          raise Constraint_Error;
 170       end if;
 171
 172       Node := New_Node (Next => B);
 173       Inserted := True;
 174
 175       B := Node;
 176       HT.Length := HT.Length + 1;
 177    end Generic_Conditional_Insert;
 178
 179    -----------
 180    -- Index --
 181    -----------
 182
 183    function Index
 184      (HT  : Hash_Table_Type;
 185       Key : Key_Type) return Hash_Type is
 186    begin
 187       return Hash (Key) mod HT.Buckets'Length;
 188    end Index;
 189
 190    -----------------------------
 191    -- Generic_Replace_Element --
 192    -----------------------------
 193
 194    procedure Generic_Replace_Element
 195      (HT   : in out Hash_Table_Type;
 196       Node : Node_Access;
 197       Key  : Key_Type)
 198    is
 199       pragma Assert (HT.Length > 0);
 200       pragma Assert (Node /= null);
 201
 202       Old_Hash : constant Hash_Type := Hash (Node);
 203       Old_Indx : constant Hash_Type := Old_Hash mod HT.Buckets'Length;
 204
 205       New_Hash : constant Hash_Type := Hash (Key);
 206       New_Indx : constant Hash_Type := New_Hash mod HT.Buckets'Length;
 207
 208       New_Bucket : Node_Access renames HT.Buckets (New_Indx);
 209       N, M       : Node_Access;
 210
 211    begin
 212       if Equivalent_Keys (Key, Node) then
 213          pragma Assert (New_Hash = Old_Hash);
 214
 215          if HT.Lock > 0 then
 216             raise Program_Error with
 217               "attempt to tamper with cursors (container is locked)";
 218          end if;
 219
 220          --  We can change a node's key to Key (that's what Assign is for), but
 221          --  only if Key is not already in the hash table. (In a unique-key
 222          --  hash table as this one a key is mapped to exactly one node only.)
 223          --  The exception is when Key is mapped to Node, in which case the
 224          --  change is allowed.
 225
 226          Assign (Node, Key);
 227          pragma Assert (Hash (Node) = New_Hash);
 228          pragma Assert (Equivalent_Keys (Key, Node));
 229          return;
 230       end if;
 231
 232       --  Key is not equivalent to Node, so we now have to determine if it's
 233       --  equivalent to some other node in the hash table. This is the case
 234       --  irrespective of whether Key is in the same or a different bucket from
 235       --  Node.
 236
 237       N := New_Bucket;
 238       while N /= null loop
 239          if Equivalent_Keys (Key, N) then
 240             pragma Assert (N /= Node);
 241             raise Program_Error with
 242               "attempt to replace existing element";
 243          end if;
 244
 245          N := Next (N);
 246       end loop;
 247
 248       --  We have determined that Key is not already in the hash table, so
 249       --  the change is tentatively allowed. We now perform the standard
 250       --  checks to determine whether the hash table is locked (because you
 251       --  cannot change an element while it's in use by Query_Element or
 252       --  Update_Element), or if the container is busy (because moving a
 253       --  node to a different bucket would interfere with iteration).
 254
 255       if Old_Indx = New_Indx then
 256          --  The node is already in the bucket implied by Key. In this case
 257          --  we merely change its value without moving it.
 258
 259          if HT.Lock > 0 then
 260             raise Program_Error with
 261               "attempt to tamper with cursors (container is locked)";
 262          end if;
 263
 264          Assign (Node, Key);
 265          pragma Assert (Hash (Node) = New_Hash);
 266          pragma Assert (Equivalent_Keys (Key, Node));
 267          return;
 268       end if;
 269
 270       --  The node is a bucket different from the bucket implied by Key
 271
 272       if HT.Busy > 0 then
 273          raise Program_Error with
 274            "attempt to tamper with elements (container is busy)";
 275       end if;
 276
 277       --  Do the assignment first, before moving the node, so that if Assign
 278       --  propagates an exception, then the hash table will not have been
 279       --  modified (except for any possible side-effect Assign had on Node).
 280
 281       Assign (Node, Key);
 282       pragma Assert (Hash (Node) = New_Hash);
 283       pragma Assert (Equivalent_Keys (Key, Node));
 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 end Ada.Containers.Hash_Tables.Generic_Keys;