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