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 --            Copyright (C) 1998-2003 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 System;        use System;
  35 with System.Memory; use System.Memory;
  36
  37 with Unchecked_Conversion;
  38
  39 package body GNAT.Table is
  40
  41    Min : constant Integer := Integer (Table_Low_Bound);
  42    --  Subscript of the minimum entry in the currently allocated table
  43
  44    Max : Integer;
  45    --  Subscript of the maximum entry in the currently allocated table
  46
  47    Length : Integer := 0;
  48    --  Number of entries in currently allocated table. The value of zero
  49    --  ensures that we initially allocate the table.
  50
  51    Last_Val : Integer;
  52    --  Current value of Last.
  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    function To_Address is new Unchecked_Conversion (Table_Ptr, Address);
  64    function To_Pointer is new Unchecked_Conversion (Address, Table_Ptr);
  65
  66    --------------
  67    -- Allocate --
  68    --------------
  69
  70    function Allocate (Num : Integer := 1) return Table_Index_Type is
  71       Old_Last : constant Integer := Last_Val;
  72
  73    begin
  74       Last_Val := Last_Val + Num;
  75
  76       if Last_Val > Max then
  77          Reallocate;
  78       end if;
  79
  80       return Table_Index_Type (Old_Last + 1);
  81    end Allocate;
  82
  83    ------------
  84    -- Append --
  85    ------------
  86
  87    procedure Append (New_Val : Table_Component_Type) is
  88    begin
  89       Increment_Last;
  90       Table (Table_Index_Type (Last_Val)) := New_Val;
  91    end Append;
  92
  93    --------------------
  94    -- Decrement_Last --
  95    --------------------
  96
  97    procedure Decrement_Last is
  98    begin
  99       Last_Val := Last_Val - 1;
 100    end Decrement_Last;
 101
 102    ----------
 103    -- Free --
 104    ----------
 105
 106    procedure Free is
 107    begin
 108       Free (To_Address (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 : constant 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       New_Size : size_t;
 170
 171    begin
 172       if Max < Last_Val then
 173          pragma Assert (not Locked);
 174
 175          while Max < Last_Val loop
 176
 177             --  Increase length using the table increment factor, but make
 178             --  sure that we add at least ten elements (this avoids a loop
 179             --  for silly small increment values)
 180
 181             Length := Integer'Max
 182                         (Length * (100 + Table_Increment) / 100,
 183                          Length + 10);
 184             Max := Min + Length - 1;
 185          end loop;
 186       end if;
 187
 188       New_Size :=
 189         size_t ((Max - Min + 1) *
 190                 (Table_Type'Component_Size / Storage_Unit));
 191
 192       if Table = null then
 193          Table := To_Pointer (Alloc (New_Size));
 194
 195       elsif New_Size > 0 then
 196          Table :=
 197            To_Pointer (Realloc (Ptr  => To_Address (Table),
 198                                 Size => New_Size));
 199       end if;
 200
 201       if Length /= 0 and then Table = null then
 202          raise Storage_Error;
 203       end if;
 204
 205    end Reallocate;
 206
 207    -------------
 208    -- Release --
 209    -------------
 210
 211    procedure Release is
 212    begin
 213       Length := Last_Val - Integer (Table_Low_Bound) + 1;
 214       Max    := Last_Val;
 215       Reallocate;
 216    end Release;
 217
 218    --------------
 219    -- Set_Item --
 220    --------------
 221
 222    procedure Set_Item
 223      (Index : Table_Index_Type;
 224       Item  : Table_Component_Type)
 225    is
 226    begin
 227       if Integer (Index) > Last_Val then
 228          Set_Last (Index);
 229       end if;
 230
 231       Table (Index) := Item;
 232    end Set_Item;
 233
 234    --------------
 235    -- Set_Last --
 236    --------------
 237
 238    procedure Set_Last (New_Val : Table_Index_Type) is
 239    begin
 240       if Integer (New_Val) < Last_Val then
 241          Last_Val := Integer (New_Val);
 242       else
 243          Last_Val := Integer (New_Val);
 244
 245          if Last_Val > Max then
 246             Reallocate;
 247          end if;
 248       end if;
 249    end Set_Last;
 250
 251 begin
 252    Init;
 253 end GNAT.Table;