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