gcc/ada/table.adb

   1 ------------------------------------------------------------------------------
   2 --                                                                          --
   3 --                         GNAT COMPILER COMPONENTS                         --
   4 --                                                                          --
   5 --                                T A B L E                                 --
   6 --                                                                          --
   7 --                                 B o d y                                  --
   8 --                                                                          --
   9 --          Copyright (C) 1992-2007, Free Software Foundation, 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,  51  Franklin  Street,  Fifth  Floor, --
  20 -- Boston, MA 02110-1301, 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 Debug;   use Debug;
  35 with Opt;     use Opt;
  36 with Output;  use Output;
  37 with System;  use System;
  38 with Tree_IO; use Tree_IO;
  39
  40 with System.Memory; use System.Memory;
  41
  42 with Unchecked_Conversion;
  43
  44 pragma Elaborate_All (Output);
  45
  46 package body Table is
  47    package body Table is
  48
  49       Min : constant Int := Int (Table_Low_Bound);
  50       --  Subscript of the minimum entry in the currently allocated table
  51
  52       Length : Int := 0;
  53       --  Number of entries in currently allocated table. The value of zero
  54       --  ensures that we initially allocate the table.
  55
  56       -----------------------
  57       -- Local Subprograms --
  58       -----------------------
  59
  60       procedure Reallocate;
  61       --  Reallocate the existing table according to the current value stored
  62       --  in Max. Works correctly to do an initial allocation if the table
  63       --  is currently null.
  64
  65       function Tree_Get_Table_Address return Address;
  66       --  Return Null_Address if the table length is zero,
  67       --  Table (First)'Address if not.
  68
  69       pragma Warnings (Off);
  70       --  Turn off warnings. The following unchecked conversions are only used
  71       --  internally in this package, and cannot never result in any instances
  72       --  of improperly aliased pointers for the client of the package.
  73
  74       function To_Address is new Unchecked_Conversion (Table_Ptr, Address);
  75       function To_Pointer is new Unchecked_Conversion (Address, Table_Ptr);
  76
  77       pragma Warnings (On);
  78
  79       ------------
  80       -- Append --
  81       ------------
  82
  83       procedure Append (New_Val : Table_Component_Type) is
  84       begin
  85          Set_Item (Table_Index_Type (Last_Val + 1), New_Val);
  86       end Append;
  87
  88       --------------------
  89       -- Decrement_Last --
  90       --------------------
  91
  92       procedure Decrement_Last is
  93       begin
  94          Last_Val := Last_Val - 1;
  95       end Decrement_Last;
  96
  97       ----------
  98       -- Free --
  99       ----------
 100
 101       procedure Free is
 102       begin
 103          Free (To_Address (Table));
 104          Table := null;
 105          Length := 0;
 106       end Free;
 107
 108       --------------------
 109       -- Increment_Last --
 110       --------------------
 111
 112       procedure Increment_Last is
 113       begin
 114          Last_Val := Last_Val + 1;
 115
 116          if Last_Val > Max then
 117             Reallocate;
 118          end if;
 119       end Increment_Last;
 120
 121       ----------
 122       -- Init --
 123       ----------
 124
 125       procedure Init is
 126          Old_Length : constant Int := Length;
 127
 128       begin
 129          Locked   := False;
 130          Last_Val := Min - 1;
 131          Max      := Min + (Table_Initial * Table_Factor) - 1;
 132          Length   := 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 = 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;
 148          end if;
 149       end Init;
 150
 151       ----------
 152       -- Last --
 153       ----------
 154
 155       function Last return Table_Index_Type is
 156       begin
 157          return Table_Index_Type (Last_Val);
 158       end Last;
 159
 160       ----------------
 161       -- Reallocate --
 162       ----------------
 163
 164       procedure Reallocate is
 165          New_Size   : Memory.size_t;
 166
 167       begin
 168          if Max < Last_Val then
 169             pragma Assert (not Locked);
 170
 171             --  Make sure that we have at least the initial allocation. This
 172             --  is needed in cases where a zero length table is written out.
 173
 174             Length := Int'Max (Length, Table_Initial);
 175
 176             --  Now increment table length until it is sufficiently large. Use
 177             --  the increment value or 10, which ever is larger (the reason
 178             --  for the use of 10 here is to ensure that the table does really
 179             --  increase in size (which would not be the case for a table of
 180             --  length 10 increased by 3% for instance).
 181
 182             while Max < Last_Val loop
 183                Length := Int'Max (Length * (100 + Table_Increment) / 100,
 184                                   Length + 10);
 185                Max := Min + Length - 1;
 186             end loop;
 187
 188             if Debug_Flag_D then
 189                Write_Str ("--> Allocating new ");
 190                Write_Str (Table_Name);
 191                Write_Str (" table, size = ");
 192                Write_Int (Max - Min + 1);
 193                Write_Eol;
 194             end if;
 195          end if;
 196
 197          New_Size :=
 198            Memory.size_t ((Max - Min + 1) *
 199                           (Table_Type'Component_Size / Storage_Unit));
 200
 201          if Table = null then
 202             Table := To_Pointer (Alloc (New_Size));
 203
 204          elsif New_Size > 0 then
 205             Table :=
 206               To_Pointer (Realloc (Ptr  => To_Address (Table),
 207                                    Size => New_Size));
 208          end if;
 209
 210          if Length /= 0 and then Table = null then
 211             Set_Standard_Error;
 212             Write_Str ("available memory exhausted");
 213             Write_Eol;
 214             Set_Standard_Output;
 215             raise Unrecoverable_Error;
 216          end if;
 217
 218       end Reallocate;
 219
 220       -------------
 221       -- Release --
 222       -------------
 223
 224       procedure Release is
 225       begin
 226          Length := Last_Val - Int (Table_Low_Bound) + 1;
 227          Max    := Last_Val;
 228          Reallocate;
 229       end Release;
 230
 231       -------------
 232       -- Restore --
 233       -------------
 234
 235       procedure Restore (T : Saved_Table) is
 236       begin
 237          Free (To_Address (Table));
 238          Last_Val := T.Last_Val;
 239          Max      := T.Max;
 240          Table    := T.Table;
 241          Length   := Max - Min + 1;
 242       end Restore;
 243
 244       ----------
 245       -- Save --
 246       ----------
 247
 248       function Save return Saved_Table is
 249          Res : Saved_Table;
 250
 251       begin
 252          Res.Last_Val := Last_Val;
 253          Res.Max      := Max;
 254          Res.Table    := Table;
 255
 256          Table  := null;
 257          Length := 0;
 258          Init;
 259          return Res;
 260       end Save;
 261
 262       --------------
 263       -- Set_Item --
 264       --------------
 265
 266       procedure Set_Item
 267          (Index : Table_Index_Type;
 268           Item  : Table_Component_Type)
 269       is
 270          --  If Item is a value within the current allocation, and we are going
 271          --  to reallocate, then we must preserve an intermediate copy here
 272          --  before calling Increment_Last. Otherwise, if Table_Component_Type
 273          --  is passed by reference, we are going to end up copying from
 274          --  storage that might have been deallocated from Increment_Last
 275          --  calling Reallocate.
 276
 277          subtype Allocated_Table_T is
 278            Table_Type (Table'First .. Table_Index_Type (Max + 1));
 279          --  A constrained table subtype one element larger than the currently
 280          --  allocated table.
 281
 282          Allocated_Table_Address : constant System.Address :=
 283                                      Table.all'Address;
 284          --  Used for address clause below (we can't use non-static expression
 285          --  Table.all'Address directly in the clause because some older
 286          --  versions of the compiler do not allow it).
 287
 288          Allocated_Table : Allocated_Table_T;
 289          pragma Import (Ada, Allocated_Table);
 290          pragma Suppress (Range_Check, On => Allocated_Table);
 291          for Allocated_Table'Address use Allocated_Table_Address;
 292          --  Allocated_Table represents the currently allocated array, plus one
 293          --  element (the supplementary element is used to have a convenient
 294          --  way of computing the address just past the end of the current
 295          --  allocation). Range checks are suppressed because this unit
 296          --  uses direct calls to System.Memory for allocation, and this can
 297          --  yield misaligned storage (and we cannot rely on the bootstrap
 298          --  compiler supporting specifically disabling alignment cheks, so we
 299          --  need to suppress all range checks). It is safe to suppress this
 300          --  check here because we know that a (possibly misaligned) object
 301          --  of that type does actually exist at that address.
 302          --  ??? We should really improve the allocation circuitry here to
 303          --  guarantee proper alignment.
 304
 305          Need_Realloc : constant Boolean := Int (Index) > Max;
 306          --  True if this operation requires storage reallocation (which may
 307          --  involve moving table contents around).
 308
 309       begin
 310          --  If we're going to reallocate, check wheter Item references an
 311          --  element of the currently allocated table.
 312
 313          if Need_Realloc
 314            and then Allocated_Table'Address <= Item'Address
 315            and then Item'Address <
 316                       Allocated_Table (Table_Index_Type (Max + 1))'Address
 317          then
 318             --  If so, save a copy on the stack because Increment_Last will
 319             --  reallocate storage and might deallocate the current table.
 320
 321             declare
 322                Item_Copy : constant Table_Component_Type := Item;
 323             begin
 324                Set_Last (Index);
 325                Table (Index) := Item_Copy;
 326             end;
 327
 328          else
 329             --  Here we know that either we won't reallocate (case of Index <
 330             --  Max) or that Item is not in the currently allocated table.
 331
 332             if Int (Index) > Last_Val then
 333                Set_Last (Index);
 334             end if;
 335
 336             Table (Index) := Item;
 337          end if;
 338       end Set_Item;
 339
 340       --------------
 341       -- Set_Last --
 342       --------------
 343
 344       procedure Set_Last (New_Val : Table_Index_Type) is
 345       begin
 346          if Int (New_Val) < Last_Val then
 347             Last_Val := Int (New_Val);
 348
 349          else
 350             Last_Val := Int (New_Val);
 351
 352             if Last_Val > Max then
 353                Reallocate;
 354             end if;
 355          end if;
 356       end Set_Last;
 357
 358       ----------------------------
 359       -- Tree_Get_Table_Address --
 360       ----------------------------
 361
 362       function Tree_Get_Table_Address return Address is
 363       begin
 364          if Length = 0 then
 365             return Null_Address;
 366          else
 367             return Table (First)'Address;
 368          end if;
 369       end Tree_Get_Table_Address;
 370
 371       ---------------
 372       -- Tree_Read --
 373       ---------------
 374
 375       --  Note: we allocate only the space required to accommodate the data
 376       --  actually written, which means that a Tree_Write/Tree_Read sequence
 377       --  does an implicit Release.
 378
 379       procedure Tree_Read is
 380       begin
 381          Tree_Read_Int (Max);
 382          Last_Val := Max;
 383          Length := Max - Min + 1;
 384          Reallocate;
 385
 386          Tree_Read_Data
 387            (Tree_Get_Table_Address,
 388              (Last_Val - Int (First) + 1) *
 389                Table_Type'Component_Size / Storage_Unit);
 390       end Tree_Read;
 391
 392       ----------------
 393       -- Tree_Write --
 394       ----------------
 395
 396       --  Note: we write out only the currently valid data, not the entire
 397       --  contents of the allocated array. See note above on Tree_Read.
 398
 399       procedure Tree_Write is
 400       begin
 401          Tree_Write_Int (Int (Last));
 402          Tree_Write_Data
 403            (Tree_Get_Table_Address,
 404             (Last_Val - Int (First) + 1) *
 405               Table_Type'Component_Size / Storage_Unit);
 406       end Tree_Write;
 407
 408    begin
 409       Init;
 410    end Table;
 411 end Table;