gcc/ada/g-dynhta.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUN-TIME COMPONENTS                         --
   4 --                                                                          --
   5 --                 G N A T . D Y N A M I C _ H T A B L E S                  --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                     Copyright (C) 2002-2006, AdaCore                     --
  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 -- GNAT was originally developed  by the GNAT team at  New York University. --
  30 -- Extensive contributions were provided by Ada Core Technologies Inc.      --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 package body GNAT.Dynamic_HTables is
  35
  36    -------------------
  37    -- Static_HTable --
  38    -------------------
  39
  40    package body Static_HTable is
  41
  42       type Table_Type is array (Header_Num) of Elmt_Ptr;
  43
  44       type Instance_Data is record
  45          Table            : Table_Type;
  46          Iterator_Index   : Header_Num;
  47          Iterator_Ptr     : Elmt_Ptr;
  48          Iterator_Started : Boolean := False;
  49       end record;
  50
  51       function Get_Non_Null (T : Instance) return Elmt_Ptr;
  52       --  Returns Null_Ptr if Iterator_Started is False or if the Table is
  53       --  empty. Returns Iterator_Ptr if non null, or the next non null
  54       --  element in table if any.
  55
  56       ---------
  57       -- Get --
  58       ---------
  59
  60       function  Get (T : Instance; K : Key) return Elmt_Ptr is
  61          Elmt  : Elmt_Ptr;
  62
  63       begin
  64          if T = null then
  65             return Null_Ptr;
  66          end if;
  67
  68          Elmt := T.Table (Hash (K));
  69
  70          loop
  71             if Elmt = Null_Ptr then
  72                return Null_Ptr;
  73
  74             elsif Equal (Get_Key (Elmt), K) then
  75                return Elmt;
  76
  77             else
  78                Elmt := Next (Elmt);
  79             end if;
  80          end loop;
  81       end Get;
  82
  83       ---------------
  84       -- Get_First --
  85       ---------------
  86
  87       function Get_First (T : Instance) return Elmt_Ptr is
  88       begin
  89          if T = null then
  90             return Null_Ptr;
  91          end if;
  92
  93          T.Iterator_Started := True;
  94          T.Iterator_Index := T.Table'First;
  95          T.Iterator_Ptr := T.Table (T.Iterator_Index);
  96          return Get_Non_Null (T);
  97       end Get_First;
  98
  99       --------------
 100       -- Get_Next --
 101       --------------
 102
 103       function Get_Next (T : Instance) return Elmt_Ptr is
 104       begin
 105          if T = null or else not T.Iterator_Started then
 106             return Null_Ptr;
 107          end if;
 108
 109          T.Iterator_Ptr := Next (T.Iterator_Ptr);
 110          return Get_Non_Null (T);
 111       end Get_Next;
 112
 113       ------------------
 114       -- Get_Non_Null --
 115       ------------------
 116
 117       function Get_Non_Null (T : Instance) return Elmt_Ptr is
 118       begin
 119          if T = null then
 120             return Null_Ptr;
 121          end if;
 122
 123          while T.Iterator_Ptr = Null_Ptr  loop
 124             if T.Iterator_Index = T.Table'Last then
 125                T.Iterator_Started := False;
 126                return Null_Ptr;
 127             end if;
 128
 129             T.Iterator_Index := T.Iterator_Index + 1;
 130             T.Iterator_Ptr   := T.Table (T.Iterator_Index);
 131          end loop;
 132
 133          return T.Iterator_Ptr;
 134       end Get_Non_Null;
 135
 136       ------------
 137       -- Remove --
 138       ------------
 139
 140       procedure Remove  (T : Instance; K : Key) is
 141          Index     : constant Header_Num := Hash (K);
 142          Elmt      : Elmt_Ptr;
 143          Next_Elmt : Elmt_Ptr;
 144
 145       begin
 146          if T = null then
 147             return;
 148          end if;
 149
 150          Elmt := T.Table (Index);
 151
 152          if Elmt = Null_Ptr then
 153             return;
 154
 155          elsif Equal (Get_Key (Elmt), K) then
 156             T.Table (Index) := Next (Elmt);
 157
 158          else
 159             loop
 160                Next_Elmt :=  Next (Elmt);
 161
 162                if Next_Elmt = Null_Ptr then
 163                   return;
 164
 165                elsif Equal (Get_Key (Next_Elmt), K) then
 166                   Set_Next (Elmt, Next (Next_Elmt));
 167                   return;
 168
 169                else
 170                   Elmt := Next_Elmt;
 171                end if;
 172             end loop;
 173          end if;
 174       end Remove;
 175
 176       -----------
 177       -- Reset --
 178       -----------
 179
 180       procedure Reset (T : in out Instance) is
 181          procedure Free is
 182            new Ada.Unchecked_Deallocation (Instance_Data, Instance);
 183
 184       begin
 185          if T = null then
 186             return;
 187          end if;
 188
 189          for J in T.Table'Range loop
 190             T.Table (J) := Null_Ptr;
 191          end loop;
 192
 193          Free (T);
 194       end Reset;
 195
 196       ---------
 197       -- Set --
 198       ---------
 199
 200       procedure Set (T : in out Instance; E : Elmt_Ptr) is
 201          Index : Header_Num;
 202
 203       begin
 204          if T = null then
 205             T := new Instance_Data;
 206          end if;
 207
 208          Index := Hash (Get_Key (E));
 209          Set_Next (E, T.Table (Index));
 210          T.Table (Index) := E;
 211       end Set;
 212
 213    end Static_HTable;
 214
 215    -------------------
 216    -- Simple_HTable --
 217    -------------------
 218
 219    package body Simple_HTable is
 220
 221       ---------
 222       -- Get --
 223       ---------
 224
 225       function  Get (T : Instance; K : Key) return Element is
 226          Tmp : Elmt_Ptr;
 227
 228       begin
 229          if T = Nil then
 230             return No_Element;
 231          end if;
 232
 233          Tmp := Tab.Get (Tab.Instance (T), K);
 234
 235          if Tmp = null then
 236             return No_Element;
 237          else
 238             return Tmp.E;
 239          end if;
 240       end Get;
 241
 242       ---------------
 243       -- Get_First --
 244       ---------------
 245
 246       function Get_First (T : Instance) return Element is
 247          Tmp : constant Elmt_Ptr := Tab.Get_First (Tab.Instance (T));
 248
 249       begin
 250          if Tmp = null then
 251             return No_Element;
 252          else
 253             return Tmp.E;
 254          end if;
 255       end Get_First;
 256
 257       -------------
 258       -- Get_Key --
 259       -------------
 260
 261       function Get_Key (E : Elmt_Ptr) return Key is
 262       begin
 263          return E.K;
 264       end Get_Key;
 265
 266       --------------
 267       -- Get_Next --
 268       --------------
 269
 270       function Get_Next (T : Instance) return Element is
 271          Tmp : constant Elmt_Ptr := Tab.Get_Next (Tab.Instance (T));
 272       begin
 273          if Tmp = null then
 274             return No_Element;
 275          else
 276             return Tmp.E;
 277          end if;
 278       end Get_Next;
 279
 280       ----------
 281       -- Next --
 282       ----------
 283
 284       function Next (E : Elmt_Ptr) return Elmt_Ptr is
 285       begin
 286          return E.Next;
 287       end Next;
 288
 289       ------------
 290       -- Remove --
 291       ------------
 292
 293       procedure Remove  (T : Instance; K : Key) is
 294          Tmp : Elmt_Ptr;
 295
 296       begin
 297          Tmp := Tab.Get (Tab.Instance (T), K);
 298
 299          if Tmp /= null then
 300             Tab.Remove (Tab.Instance (T), K);
 301             Free (Tmp);
 302          end if;
 303       end Remove;
 304
 305       -----------
 306       -- Reset --
 307       -----------
 308
 309       procedure Reset (T : in out Instance) is
 310          E1, E2 : Elmt_Ptr;
 311
 312       begin
 313          E1 := Tab.Get_First (Tab.Instance (T));
 314          while E1 /= null loop
 315             E2 := Tab.Get_Next (Tab.Instance (T));
 316             Free (E1);
 317             E1 := E2;
 318          end loop;
 319
 320          Tab.Reset (Tab.Instance (T));
 321       end Reset;
 322
 323       ---------
 324       -- Set --
 325       ---------
 326
 327       procedure Set (T : in out Instance; K : Key; E : Element) is
 328          Tmp : constant Elmt_Ptr := Tab.Get (Tab.Instance (T), K);
 329       begin
 330          if Tmp = null then
 331             Tab.Set (Tab.Instance (T), new Element_Wrapper'(K, E, null));
 332          else
 333             Tmp.E := E;
 334          end if;
 335       end Set;
 336
 337       --------------
 338       -- Set_Next --
 339       --------------
 340
 341       procedure Set_Next (E : Elmt_Ptr; Next : Elmt_Ptr) is
 342       begin
 343          E.Next := Next;
 344       end Set_Next;
 345
 346    end Simple_HTable;
 347
 348 end GNAT.Dynamic_HTables;