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-2006, 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;
  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;
  80             end if;
  81             Set_Next (Node => Prev, Next => Next (X));
  82             HT.Length := HT.Length - 1;
  83             return;
  84          end if;
  85       end loop;
  86    end Delete_Key_Sans_Free;
  87
  88    ----------
  89    -- Find --
  90    ----------
  91
  92    function Find
  93      (HT  : Hash_Table_Type;
  94       Key : Key_Type) return Node_Access is
  95
  96       Indx : Hash_Type;
  97       Node : Node_Access;
  98
  99    begin
 100       if HT.Length = 0 then
 101          return null;
 102       end if;
 103
 104       Indx := Index (HT, Key);
 105
 106       Node := HT.Buckets (Indx);
 107       while Node /= null loop
 108          if Equivalent_Keys (Key, Node) then
 109             return Node;
 110          end if;
 111          Node := Next (Node);
 112       end loop;
 113
 114       return null;
 115    end Find;
 116
 117    --------------------------------
 118    -- Generic_Conditional_Insert --
 119    --------------------------------
 120
 121    procedure Generic_Conditional_Insert
 122      (HT       : in out Hash_Table_Type;
 123       Key      : Key_Type;
 124       Node     : out Node_Access;
 125       Inserted : out Boolean)
 126    is
 127       Indx : constant Hash_Type := Index (HT, Key);
 128       B    : Node_Access renames HT.Buckets (Indx);
 129
 130    begin
 131       if B = null then
 132          if HT.Busy > 0 then
 133             raise Program_Error;
 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;
 163       end if;
 164
 165       if HT.Length = Count_Type'Last then
 166          raise Constraint_Error;
 167       end if;
 168
 169       Node := New_Node (Next => B);
 170       Inserted := True;
 171
 172       B := Node;
 173       HT.Length := HT.Length + 1;
 174    end Generic_Conditional_Insert;
 175
 176    -----------
 177    -- Index --
 178    -----------
 179
 180    function Index
 181      (HT  : Hash_Table_Type;
 182       Key : Key_Type) return Hash_Type is
 183    begin
 184       return Hash (Key) mod HT.Buckets'Length;
 185    end Index;
 186
 187    ---------------------
 188    -- Replace_Element --
 189    ---------------------
 190
 191    procedure Generic_Replace_Element
 192      (HT   : in out Hash_Table_Type;
 193       Node : Node_Access;
 194       Key  : Key_Type)
 195    is
 196    begin
 197       pragma Assert (HT.Length > 0);
 198
 199       if Equivalent_Keys (Key, Node) then
 200          pragma Assert (Hash (Key) = Hash (Node));
 201
 202          if HT.Lock > 0 then
 203             raise Program_Error with
 204               "attempt to tamper with cursors (container is locked)";
 205          end if;
 206
 207          Assign (Node, Key);
 208          return;
 209       end if;
 210
 211       declare
 212          J : Hash_Type;
 213          K : constant Hash_Type := Index (HT, Key);
 214          B : Node_Access renames HT.Buckets (K);
 215          N : Node_Access := B;
 216          M : Node_Access;
 217
 218       begin
 219          while N /= null loop
 220             if Equivalent_Keys (Key, N) then
 221                raise Program_Error with
 222                  "attempt to replace existing element";
 223             end if;
 224
 225             N := Next (N);
 226          end loop;
 227
 228          J := Hash (Node);
 229
 230          if J = K then
 231             if HT.Lock > 0 then
 232                raise Program_Error with
 233                  "attempt to tamper with cursors (container is locked)";
 234             end if;
 235
 236             Assign (Node, Key);
 237             return;
 238          end if;
 239
 240          if HT.Busy > 0 then
 241             raise Program_Error with
 242               "attempt to tamper with elements (container is busy)";
 243          end if;
 244
 245          Assign (Node, Key);
 246
 247          N := HT.Buckets (J);
 248          pragma Assert (N /= null);
 249
 250          if N = Node then
 251             HT.Buckets (J) := Next (Node);
 252
 253          else
 254             pragma Assert (HT.Length > 1);
 255
 256             loop
 257                M := Next (N);
 258                pragma Assert (M /= null);
 259
 260                if M = Node then
 261                   Set_Next (Node => N, Next => Next (Node));
 262                   exit;
 263                end if;
 264
 265                N := M;
 266             end loop;
 267          end if;
 268
 269          Set_Next (Node => Node, Next => B);
 270          B := Node;
 271       end;
 272    end Generic_Replace_Element;
 273
 274 end Ada.Containers.Hash_Tables.Generic_Keys;