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