gcc/ada/g-dynhta.adb

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