gcc/ada/g-table.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT RUNTIME COMPONENTS                          --
   4 --                                                                          --
   5 --                            G N A T .  T A B L E                          --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                            $Revision: 1.8 $
  10 --                                                                          --
  11 --            Copyright (C) 1998-2001 Ada Core Technologies, Inc.           --
  12 --                                                                          --
  13 -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14 -- terms of the  GNU General Public License as published  by the Free Soft- --
  15 -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16 -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17 -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18 -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19 -- for  more details.  You should have  received  a copy of the GNU General --
  20 -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21 -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22 -- MA 02111-1307, USA.                                                      --
  23 --                                                                          --
  24 -- As a special exception,  if other files  instantiate  generics from this --
  25 -- unit, or you link  this unit with other files  to produce an executable, --
  26 -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27 -- covered  by the  GNU  General  Public  License.  This exception does not --
  28 -- however invalidate  any other reasons why  the executable file  might be --
  29 -- covered by the  GNU Public License.                                      --
  30 --                                                                          --
  31 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com).   --
  32 --                                                                          --
  33 ------------------------------------------------------------------------------
  34
  35 with System; use System;
  36
  37 package body GNAT.Table is
  38
  39    Min : constant Integer := Integer (Table_Low_Bound);
  40    --  Subscript of the minimum entry in the currently allocated table
  41
  42    Max : Integer;
  43    --  Subscript of the maximum entry in the currently allocated table
  44
  45    Length : Integer := 0;
  46    --  Number of entries in currently allocated table. The value of zero
  47    --  ensures that we initially allocate the table.
  48
  49    Last_Val : Integer;
  50    --  Current value of Last.
  51
  52    type size_t is new Integer;
  53
  54    -----------------------
  55    -- Local Subprograms --
  56    -----------------------
  57
  58    procedure Reallocate;
  59    --  Reallocate the existing table according to the current value stored
  60    --  in Max. Works correctly to do an initial allocation if the table
  61    --  is currently null.
  62
  63    --------------
  64    -- Allocate --
  65    --------------
  66
  67    function Allocate (Num : Integer := 1) return Table_Index_Type is
  68       Old_Last : constant Integer := Last_Val;
  69
  70    begin
  71       Last_Val := Last_Val + Num;
  72
  73       if Last_Val > Max then
  74          Reallocate;
  75       end if;
  76
  77       return Table_Index_Type (Old_Last + 1);
  78    end Allocate;
  79
  80    ------------
  81    -- Append --
  82    ------------
  83
  84    procedure Append (New_Val : Table_Component_Type) is
  85    begin
  86       Increment_Last;
  87       Table (Table_Index_Type (Last_Val)) := New_Val;
  88    end Append;
  89
  90    --------------------
  91    -- Decrement_Last --
  92    --------------------
  93
  94    procedure Decrement_Last is
  95    begin
  96       Last_Val := Last_Val - 1;
  97    end Decrement_Last;
  98
  99    ----------
 100    -- Free --
 101    ----------
 102
 103    procedure Free is
 104       procedure free (T : Table_Ptr);
 105       pragma Import (C, free);
 106
 107    begin
 108       free (Table);
 109       Table := null;
 110       Length := 0;
 111    end Free;
 112
 113    --------------------
 114    -- Increment_Last --
 115    --------------------
 116
 117    procedure Increment_Last is
 118    begin
 119       Last_Val := Last_Val + 1;
 120
 121       if Last_Val > Max then
 122          Reallocate;
 123       end if;
 124    end Increment_Last;
 125
 126    ----------
 127    -- Init --
 128    ----------
 129
 130    procedure Init is
 131       Old_Length : Integer := Length;
 132
 133    begin
 134       Last_Val := Min - 1;
 135       Max      := Min + Table_Initial - 1;
 136       Length   := Max - Min + 1;
 137
 138       --  If table is same size as before (happens when table is never
 139       --  expanded which is a common case), then simply reuse it. Note
 140       --  that this also means that an explicit Init call right after
 141       --  the implicit one in the package body is harmless.
 142
 143       if Old_Length = Length then
 144          return;
 145
 146       --  Otherwise we can use Reallocate to get a table of the right size.
 147       --  Note that Reallocate works fine to allocate a table of the right
 148       --  initial size when it is first allocated.
 149
 150       else
 151          Reallocate;
 152       end if;
 153    end Init;
 154
 155    ----------
 156    -- Last --
 157    ----------
 158
 159    function Last return Table_Index_Type is
 160    begin
 161       return Table_Index_Type (Last_Val);
 162    end Last;
 163
 164    ----------------
 165    -- Reallocate --
 166    ----------------
 167
 168    procedure Reallocate is
 169
 170       function realloc
 171         (memblock : Table_Ptr;
 172          size     : size_t)
 173          return     Table_Ptr;
 174       pragma Import (C, realloc);
 175
 176       function malloc
 177         (size     : size_t)
 178          return     Table_Ptr;
 179       pragma Import (C, malloc);
 180
 181       New_Size : size_t;
 182
 183    begin
 184       if Max < Last_Val then
 185          pragma Assert (not Locked);
 186
 187          while Max < Last_Val loop
 188
 189             --  Increase length using the table increment factor, but make
 190             --  sure that we add at least ten elements (this avoids a loop
 191             --  for silly small increment values)
 192
 193             Length := Integer'Max
 194                         (Length * (100 + Table_Increment) / 100,
 195                          Length + 10);
 196             Max := Min + Length - 1;
 197          end loop;
 198       end if;
 199
 200       New_Size :=
 201         size_t ((Max - Min + 1) *
 202                 (Table_Type'Component_Size / Storage_Unit));
 203
 204       if Table = null then
 205          Table := malloc (New_Size);
 206
 207       elsif New_Size > 0 then
 208          Table :=
 209            realloc
 210              (memblock => Table,
 211               size     => New_Size);
 212       end if;
 213
 214       if Length /= 0 and then Table = null then
 215          raise Storage_Error;
 216       end if;
 217
 218    end Reallocate;
 219
 220    -------------
 221    -- Release --
 222    -------------
 223
 224    procedure Release is
 225    begin
 226       Length := Last_Val - Integer (Table_Low_Bound) + 1;
 227       Max    := Last_Val;
 228       Reallocate;
 229    end Release;
 230
 231    --------------
 232    -- Set_Item --
 233    --------------
 234
 235    procedure Set_Item
 236      (Index : Table_Index_Type;
 237       Item  : Table_Component_Type)
 238    is
 239    begin
 240       if Integer (Index) > Max then
 241          Set_Last (Index);
 242       end if;
 243
 244       Table (Index) := Item;
 245    end Set_Item;
 246
 247    --------------
 248    -- Set_Last --
 249    --------------
 250
 251    procedure Set_Last (New_Val : Table_Index_Type) is
 252    begin
 253       if Integer (New_Val) < Last_Val then
 254          Last_Val := Integer (New_Val);
 255       else
 256          Last_Val := Integer (New_Val);
 257
 258          if Last_Val > Max then
 259             Reallocate;
 260          end if;
 261       end if;
 262    end Set_Last;
 263
 264 begin
 265    Init;
 266 end GNAT.Table;