gcc/ada/g-dyntab.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                   G N A T . D Y N A M I C _ T A B L E S                  --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --                                                                          --
  10 --           Copyright (C) 2000-2001 Ada Core Technologies, 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,  59 Temple Place - Suite 330,  Boston, --
  21 -- MA 02111-1307, 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 -- GNAT is maintained by Ada Core Technologies Inc (http://www.gnat.com).   --
  31 --                                                                          --
  32 ------------------------------------------------------------------------------
  33
  34 with System;        use System;
  35 with System.Memory; use System.Memory;
  36 with System.Address_To_Access_Conversions;
  37
  38 package body GNAT.Dynamic_Tables is
  39
  40    Min : constant Integer := Integer (Table_Low_Bound);
  41    --  Subscript of the minimum entry in the currently allocated table
  42
  43    -----------------------
  44    -- Local Subprograms --
  45    -----------------------
  46
  47    procedure Reallocate (T : in out Instance);
  48    --  Reallocate the existing table according to the current value stored
  49    --  in Max. Works correctly to do an initial allocation if the table
  50    --  is currently null.
  51
  52    package Table_Conversions is
  53       new System.Address_To_Access_Conversions (Big_Table_Type);
  54    --  Address and Access conversions for a Table object.
  55
  56    function To_Address (Table : Table_Ptr) return Address;
  57    pragma Inline (To_Address);
  58    --  Returns the Address for the Table object.
  59
  60    function To_Pointer (Table : Address) return Table_Ptr;
  61    pragma Inline (To_Pointer);
  62    --  Returns the Access pointer for the Table object.
  63
  64    --------------
  65    -- Allocate --
  66    --------------
  67
  68    procedure Allocate
  69      (T   : in out Instance;
  70       Num : Integer := 1)
  71    is
  72    begin
  73       T.P.Last_Val := T.P.Last_Val + Num;
  74
  75       if T.P.Last_Val > T.P.Max then
  76          Reallocate (T);
  77       end if;
  78    end Allocate;
  79
  80    ------------
  81    -- Append --
  82    ------------
  83
  84    procedure Append (T : in out Instance; New_Val : Table_Component_Type) is
  85    begin
  86       Increment_Last (T);
  87       T.Table (Table_Index_Type (T.P.Last_Val)) := New_Val;
  88    end Append;
  89
  90    --------------------
  91    -- Decrement_Last --
  92    --------------------
  93
  94    procedure Decrement_Last (T : in out Instance) is
  95    begin
  96       T.P.Last_Val := T.P.Last_Val - 1;
  97    end Decrement_Last;
  98
  99    ----------
 100    -- Free --
 101    ----------
 102
 103    procedure Free (T : in out Instance) is
 104    begin
 105       Free (To_Address (T.Table));
 106       T.Table := null;
 107       T.P.Length := 0;
 108    end Free;
 109
 110    --------------------
 111    -- Increment_Last --
 112    --------------------
 113
 114    procedure Increment_Last (T : in out Instance) is
 115    begin
 116       T.P.Last_Val := T.P.Last_Val + 1;
 117
 118       if T.P.Last_Val > T.P.Max then
 119          Reallocate (T);
 120       end if;
 121    end Increment_Last;
 122
 123    ----------
 124    -- Init --
 125    ----------
 126
 127    procedure Init (T : in out Instance) is
 128       Old_Length : constant Integer := T.P.Length;
 129
 130    begin
 131       T.P.Last_Val := Min - 1;
 132       T.P.Max      := Min + Table_Initial - 1;
 133       T.P.Length   := T.P.Max - Min + 1;
 134
 135       --  If table is same size as before (happens when table is never
 136       --  expanded which is a common case), then simply reuse it. Note
 137       --  that this also means that an explicit Init call right after
 138       --  the implicit one in the package body is harmless.
 139
 140       if Old_Length = T.P.Length then
 141          return;
 142
 143       --  Otherwise we can use Reallocate to get a table of the right size.
 144       --  Note that Reallocate works fine to allocate a table of the right
 145       --  initial size when it is first allocated.
 146
 147       else
 148          Reallocate (T);
 149       end if;
 150    end Init;
 151
 152    ----------
 153    -- Last --
 154    ----------
 155
 156    function Last (T : in Instance) return Table_Index_Type is
 157    begin
 158       return Table_Index_Type (T.P.Last_Val);
 159    end Last;
 160
 161    ----------------
 162    -- Reallocate --
 163    ----------------
 164
 165    procedure Reallocate (T : in out Instance) is
 166       New_Size : size_t;
 167
 168    begin
 169       if T.P.Max < T.P.Last_Val then
 170          while T.P.Max < T.P.Last_Val loop
 171             T.P.Length := T.P.Length * (100 + Table_Increment) / 100;
 172             T.P.Max := Min + T.P.Length - 1;
 173          end loop;
 174       end if;
 175
 176       New_Size :=
 177         size_t ((T.P.Max - Min + 1) *
 178                 (Table_Type'Component_Size / Storage_Unit));
 179
 180       if T.Table = null then
 181          T.Table := To_Pointer (Alloc (New_Size));
 182
 183       elsif New_Size > 0 then
 184          T.Table :=
 185            To_Pointer (Realloc (Ptr  => To_Address (T.Table),
 186                                 Size => New_Size));
 187       end if;
 188
 189       if T.P.Length /= 0 and then T.Table = null then
 190          raise Storage_Error;
 191       end if;
 192
 193    end Reallocate;
 194
 195    -------------
 196    -- Release --
 197    -------------
 198
 199    procedure Release (T : in out Instance) is
 200    begin
 201       T.P.Length := T.P.Last_Val - Integer (Table_Low_Bound) + 1;
 202       T.P.Max    := T.P.Last_Val;
 203       Reallocate (T);
 204    end Release;
 205
 206    --------------
 207    -- Set_Item --
 208    --------------
 209
 210    procedure Set_Item
 211      (T     : in out Instance;
 212       Index : Table_Index_Type;
 213       Item  : Table_Component_Type)
 214    is
 215    begin
 216       if Integer (Index) > T.P.Max then
 217          Set_Last (T, Index);
 218       end if;
 219
 220       T.Table (Index) := Item;
 221    end Set_Item;
 222
 223    --------------
 224    -- Set_Last --
 225    --------------
 226
 227    procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type) is
 228    begin
 229       if Integer (New_Val) < T.P.Last_Val then
 230          T.P.Last_Val := Integer (New_Val);
 231
 232       else
 233          T.P.Last_Val := Integer (New_Val);
 234
 235          if T.P.Last_Val > T.P.Max then
 236             Reallocate (T);
 237          end if;
 238       end if;
 239    end Set_Last;
 240
 241    ----------------
 242    -- To_Address --
 243    ----------------
 244
 245    function To_Address (Table : Table_Ptr) return Address is
 246    begin
 247       return Table_Conversions.To_Address
 248         (Table_Conversions.Object_Pointer (Table));
 249    end To_Address;
 250
 251    ----------------
 252    -- To_Pointer --
 253    ----------------
 254
 255    function To_Pointer (Table : Address) return Table_Ptr is
 256    begin
 257       return Table_Ptr (Table_Conversions.To_Pointer (Table));
 258    end To_Pointer;
 259
 260 end GNAT.Dynamic_Tables;