gcc/ada/a-chtgke.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT LIBRARY COMPONENTS                          --
   4 --                                                                          --
   5 --                      A D A . C O N T A I N E R S .                       --
   6 --             H A S H _ T A B L E S . G E N E R I C _ K E Y S              --
   7 --                                                                          --
   8 --                                 B o d y                                  --
   9 --                                                                          --
  10 --          Copyright (C) 2004-2007, Free Software Foundation, Inc.         --
  11 --                                                                          --
  12 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  13 -- terms of the  GNU General Public License as published  by the Free Soft- --
  14 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  15 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  16 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  17 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  18 -- for  more details.  You should have  received  a copy of the GNU General --
  19 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  20 -- to  the  Free Software Foundation,  51  Franklin  Street,  Fifth  Floor, --
  21 -- Boston, MA 02110-1301, USA.                                              --
  22 --                                                                          --
  23 -- As a special exception,  if other files  instantiate  generics from this --
  24 -- unit, or you link  this unit with other files  to produce an executable, --
  25 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  26 -- covered  by the  GNU  General  Public  License.  This exception does not --
  27 -- however invalidate  any other reasons why  the executable file  might be --
  28 -- covered by the  GNU Public License.                                      --
  29 --                                                                          --
  30 -- This unit was originally developed by Matthew J Heaney.                  --
  31 ------------------------------------------------------------------------------
  32
  33 package body Ada.Containers.Hash_Tables.Generic_Keys is
  34
  35    --------------------------
  36    -- Delete_Key_Sans_Free --
  37    --------------------------
  38
  39    procedure Delete_Key_Sans_Free
  40      (HT  : in out Hash_Table_Type;
  41       Key : Key_Type;
  42       X   : out Node_Access)
  43    is
  44       Indx : Hash_Type;
  45       Prev : Node_Access;
  46
  47    begin
  48       if HT.Length = 0 then
  49          X := null;
  50          return;
  51       end if;
  52
  53       Indx := Index (HT, Key);
  54       X := HT.Buckets (Indx);
  55
  56       if X = null then
  57          return;
  58       end if;
  59
  60       if Equivalent_Keys (Key, X) then
  61          if HT.Busy > 0 then
  62             raise Program_Error with
  63               "attempt to tamper with elements (container is busy)";
  64          end if;
  65          HT.Buckets (Indx) := Next (X);
  66          HT.Length := HT.Length - 1;
  67          return;
  68       end if;
  69
  70       loop
  71          Prev := X;
  72          X := Next (Prev);
  73
  74          if X = null then
  75             return;
  76          end if;
  77
  78          if Equivalent_Keys (Key, X) then
  79             if HT.Busy > 0 then
  80                raise Program_Error with
  81                  "attempt to tamper with elements (container is busy)";
  82             end if;
  83             Set_Next (Node => Prev, Next => Next (X));
  84             HT.Length := HT.Length - 1;
  85             return;
  86          end if;
  87       end loop;
  88    end Delete_Key_Sans_Free;
  89
  90    ----------
  91    -- Find --
  92    ----------
  93
  94    function Find
  95      (HT  : Hash_Table_Type;
  96       Key : Key_Type) return Node_Access is
  97
  98       Indx : Hash_Type;
  99       Node : Node_Access;
 100
 101    begin
 102       if HT.Length = 0 then
 103          return null;
 104       end if;
 105
 106       Indx := Index (HT, Key);
 107
 108       Node := HT.Buckets (Indx);
 109       while Node /= null loop
 110          if Equivalent_Keys (Key, Node) then
 111             return Node;
 112          end if;
 113          Node := Next (Node);
 114       end loop;
 115
 116       return null;
 117    end Find;
 118
 119    --------------------------------
 120    -- Generic_Conditional_Insert --
 121    --------------------------------
 122
 123    procedure Generic_Conditional_Insert
 124      (HT       : in out Hash_Table_Type;
 125       Key      : Key_Type;
 126       Node     : out Node_Access;
 127       Inserted : out Boolean)
 128    is
 129       Indx : constant Hash_Type := Index (HT, Key);
 130       B    : Node_Access renames HT.Buckets (Indx);
 131
 132    begin
 133       if B = null then
 134          if HT.Busy > 0 then
 135             raise Program_Error with
 136               "attempt to tamper with elements (container is busy)";
 137          end if;
 138
 139          if HT.Length = Count_Type'Last then
 140             raise Constraint_Error;
 141          end if;
 142
 143          Node := New_Node (Next => null);
 144          Inserted := True;
 145
 146          B := Node;
 147          HT.Length := HT.Length + 1;
 148
 149          return;
 150       end if;
 151
 152       Node := B;
 153       loop
 154          if Equivalent_Keys (Key, Node) then
 155             Inserted := False;
 156             return;
 157          end if;
 158
 159          Node := Next (Node);
 160
 161          exit when Node = null;
 162       end loop;
 163
 164       if HT.Busy > 0 then
 165          raise Program_Error with
 166            "attempt to tamper with elements (container is busy)";
 167       end if;
 168
 169       if HT.Length = Count_Type'Last then
 170          raise Constraint_Error;
 171       end if;
 172
 173       Node := New_Node (Next => B);
 174       Inserted := True;
 175
 176       B := Node;
 177       HT.Length := HT.Length + 1;
 178    end Generic_Conditional_Insert;
 179
 180    -----------
 181    -- Index --
 182    -----------
 183
 184    function Index
 185      (HT  : Hash_Table_Type;
 186       Key : Key_Type) return Hash_Type is
 187    begin
 188       return Hash (Key) mod HT.Buckets'Length;
 189    end Index;
 190
 191    -----------------------------
 192    -- Generic_Replace_Element --
 193    -----------------------------
 194
 195    procedure Generic_Replace_Element
 196      (HT   : in out Hash_Table_Type;
 197       Node : Node_Access;
 198       Key  : Key_Type)
 199    is
 200       pragma Assert (HT.Length > 0);
 201       pragma Assert (Node /= null);
 202
 203       Old_Hash : constant Hash_Type := Hash (Node);
 204       Old_Indx : constant Hash_Type := Old_Hash mod HT.Buckets'Length;
 205
 206       New_Hash : constant Hash_Type := Hash (Key);
 207       New_Indx : constant Hash_Type := New_Hash mod HT.Buckets'Length;
 208
 209       New_Bucket : Node_Access renames HT.Buckets (New_Indx);
 210       N, M       : Node_Access;
 211
 212    begin
 213       if Equivalent_Keys (Key, Node) then
 214          pragma Assert (New_Hash = Old_Hash);
 215
 216          if HT.Lock > 0 then
 217             raise Program_Error with
 218               "attempt to tamper with cursors (container is locked)";
 219          end if;
 220
 221          --  We can change a node's key to Key (that's what Assign is for), but
 222          --  only if Key is not already in the hash table. (In a unique-key
 223          --  hash table as this one a key is mapped to exactly one node only.)
 224          --  The exception is when Key is mapped to Node, in which case the
 225          --  change is allowed.
 226
 227          Assign (Node, Key);
 228          pragma Assert (Hash (Node) = New_Hash);
 229          pragma Assert (Equivalent_Keys (Key, Node));
 230          return;
 231       end if;
 232
 233       --  Key is not equivalent to Node, so we now have to determine if it's
 234       --  equivalent to some other node in the hash table. This is the case
 235       --  irrespective of whether Key is in the same or a different bucket from
 236       --  Node.
 237
 238       N := New_Bucket;
 239       while N /= null loop
 240          if Equivalent_Keys (Key, N) then
 241             pragma Assert (N /= Node);
 242             raise Program_Error with
 243               "attempt to replace existing element";
 244          end if;
 245
 246          N := Next (N);
 247       end loop;
 248
 249       --  We have determined that Key is not already in the hash table, so
 250       --  the change is tenatively allowed. We now perform the standard
 251       --  checks to determine whether the hash table is locked (because you
 252       --  cannot change an element while it's in use by Query_Element or
 253       --  Update_Element), or if the container is busy (because moving a
 254       --  node to a different bucket would interfere with iteration).
 255
 256       if Old_Indx = New_Indx then
 257          --  The node is already in the bucket implied by Key. In this case
 258          --  we merely change its value without moving it.
 259
 260          if HT.Lock > 0 then
 261             raise Program_Error with
 262               "attempt to tamper with cursors (container is locked)";
 263          end if;
 264
 265          Assign (Node, Key);
 266          pragma Assert (Hash (Node) = New_Hash);
 267          pragma Assert (Equivalent_Keys (Key, Node));
 268          return;
 269       end if;
 270
 271       --  The node is a bucket different from the bucket implied by Key
 272
 273       if HT.Busy > 0 then
 274          raise Program_Error with
 275            "attempt to tamper with elements (container is busy)";
 276       end if;
 277
 278       --  Do the assignment first, before moving the node, so that if Assign
 279       --  propagates an exception, then the hash table will not have been
 280       --  modified (except for any possible side-effect Assign had on Node).
 281
 282       Assign (Node, Key);
 283       pragma Assert (Hash (Node) = New_Hash);
 284       pragma Assert (Equivalent_Keys (Key, Node));
 285
 286       --  Now we can safely remove the node from its current bucket
 287
 288       N := HT.Buckets (Old_Indx);
 289       pragma Assert (N /= null);
 290
 291       if N = Node then
 292          HT.Buckets (Old_Indx) := Next (Node);
 293
 294       else
 295          pragma Assert (HT.Length > 1);
 296
 297          loop
 298             M := Next (N);
 299             pragma Assert (M /= null);
 300
 301             if M = Node then
 302                Set_Next (Node => N, Next => Next (Node));
 303                exit;
 304             end if;
 305
 306             N := M;
 307          end loop;
 308       end if;
 309
 310       --  Now we link the node into its new bucket (corresponding to Key)
 311
 312       Set_Next (Node => Node, Next => New_Bucket);
 313       New_Bucket := Node;
 314    end Generic_Replace_Element;
 315
 316 end Ada.Containers.Hash_Tables.Generic_Keys;