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-2009, AdaCore                     --
  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 pragma Compiler_Unit;
  35
  36 with GNAT.Heap_Sort_G;
  37 with System;        use System;
  38 with System.Memory; use System.Memory;
  39
  40 with Ada.Unchecked_Conversion;
  41
  42 package body GNAT.Dynamic_Tables is
  43
  44    Min : constant Integer := Integer (Table_Low_Bound);
  45    --  Subscript of the minimum entry in the currently allocated table
  46
  47    -----------------------
  48    -- Local Subprograms --
  49    -----------------------
  50
  51    procedure Reallocate (T : in out Instance);
  52    --  Reallocate the existing table according to the current value stored
  53    --  in Max. Works correctly to do an initial allocation if the table
  54    --  is currently null.
  55
  56    pragma Warnings (Off);
  57    --  These unchecked conversions are in fact safe, since they never
  58    --  generate improperly aliased pointer values.
  59
  60    function To_Address is new Ada.Unchecked_Conversion (Table_Ptr, Address);
  61    function To_Pointer is new Ada.Unchecked_Conversion (Address, Table_Ptr);
  62
  63    pragma Warnings (On);
  64
  65    --------------
  66    -- Allocate --
  67    --------------
  68
  69    procedure Allocate (T : in out Instance; Num : Integer := 1) is
  70    begin
  71       T.P.Last_Val := T.P.Last_Val + Num;
  72
  73       if T.P.Last_Val > T.P.Max then
  74          Reallocate (T);
  75       end if;
  76    end Allocate;
  77
  78    ------------
  79    -- Append --
  80    ------------
  81
  82    procedure Append (T : in out Instance; New_Val : Table_Component_Type) is
  83    begin
  84       Set_Item (T, Table_Index_Type (T.P.Last_Val + 1), New_Val);
  85    end Append;
  86
  87    ----------------
  88    -- Append_All --
  89    ----------------
  90
  91    procedure Append_All (T : in out Instance; New_Vals : Table_Type) is
  92    begin
  93       for J in New_Vals'Range loop
  94          Append (T, New_Vals (J));
  95       end loop;
  96    end Append_All;
  97
  98    --------------------
  99    -- Decrement_Last --
 100    --------------------
 101
 102    procedure Decrement_Last (T : in out Instance) is
 103    begin
 104       T.P.Last_Val := T.P.Last_Val - 1;
 105    end Decrement_Last;
 106
 107    --------------
 108    -- For_Each --
 109    --------------
 110
 111    procedure For_Each (Table : Instance) is
 112       Quit : Boolean := False;
 113    begin
 114       for Index in Table_Low_Bound .. Table_Index_Type (Table.P.Last_Val) loop
 115          Action (Index, Table.Table (Index), Quit);
 116          exit when Quit;
 117       end loop;
 118    end For_Each;
 119
 120    ----------
 121    -- Free --
 122    ----------
 123
 124    procedure Free (T : in out Instance) is
 125    begin
 126       Free (To_Address (T.Table));
 127       T.Table := null;
 128       T.P.Length := 0;
 129    end Free;
 130
 131    --------------------
 132    -- Increment_Last --
 133    --------------------
 134
 135    procedure Increment_Last (T : in out Instance) is
 136    begin
 137       T.P.Last_Val := T.P.Last_Val + 1;
 138
 139       if T.P.Last_Val > T.P.Max then
 140          Reallocate (T);
 141       end if;
 142    end Increment_Last;
 143
 144    ----------
 145    -- Init --
 146    ----------
 147
 148    procedure Init (T : in out Instance) is
 149       Old_Length : constant Integer := T.P.Length;
 150
 151    begin
 152       T.P.Last_Val := Min - 1;
 153       T.P.Max      := Min + Table_Initial - 1;
 154       T.P.Length   := T.P.Max - Min + 1;
 155
 156       --  If table is same size as before (happens when table is never
 157       --  expanded which is a common case), then simply reuse it. Note
 158       --  that this also means that an explicit Init call right after
 159       --  the implicit one in the package body is harmless.
 160
 161       if Old_Length = T.P.Length then
 162          return;
 163
 164       --  Otherwise we can use Reallocate to get a table of the right size.
 165       --  Note that Reallocate works fine to allocate a table of the right
 166       --  initial size when it is first allocated.
 167
 168       else
 169          Reallocate (T);
 170       end if;
 171    end Init;
 172
 173    ----------
 174    -- Last --
 175    ----------
 176
 177    function Last (T : Instance) return Table_Index_Type is
 178    begin
 179       return Table_Index_Type (T.P.Last_Val);
 180    end Last;
 181
 182    ----------------
 183    -- Reallocate --
 184    ----------------
 185
 186    procedure Reallocate (T : in out Instance) is
 187       New_Length : Integer;
 188       New_Size   : size_t;
 189
 190    begin
 191       if T.P.Max < T.P.Last_Val then
 192          while T.P.Max < T.P.Last_Val loop
 193             New_Length := T.P.Length * (100 + Table_Increment) / 100;
 194
 195             if New_Length > T.P.Length then
 196                T.P.Length := New_Length;
 197             else
 198                T.P.Length := T.P.Length + 1;
 199             end if;
 200
 201             T.P.Max := Min + T.P.Length - 1;
 202          end loop;
 203       end if;
 204
 205       New_Size :=
 206         size_t ((T.P.Max - Min + 1) *
 207                 (Table_Type'Component_Size / Storage_Unit));
 208
 209       if T.Table = null then
 210          T.Table := To_Pointer (Alloc (New_Size));
 211
 212       elsif New_Size > 0 then
 213          T.Table :=
 214            To_Pointer (Realloc (Ptr  => To_Address (T.Table),
 215                                 Size => New_Size));
 216       end if;
 217
 218       if T.P.Length /= 0 and then T.Table = null then
 219          raise Storage_Error;
 220       end if;
 221    end Reallocate;
 222
 223    -------------
 224    -- Release --
 225    -------------
 226
 227    procedure Release (T : in out Instance) is
 228    begin
 229       T.P.Length := T.P.Last_Val - Integer (Table_Low_Bound) + 1;
 230       T.P.Max    := T.P.Last_Val;
 231       Reallocate (T);
 232    end Release;
 233
 234    --------------
 235    -- Set_Item --
 236    --------------
 237
 238    procedure Set_Item
 239       (T     : in out Instance;
 240        Index : Table_Index_Type;
 241        Item  : Table_Component_Type)
 242    is
 243       --  If Item is a value within the current allocation, and we are going to
 244       --  reallocate, then we must preserve an intermediate copy here before
 245       --  calling Increment_Last. Otherwise, if Table_Component_Type is passed
 246       --  by reference, we are going to end up copying from storage that might
 247       --  have been deallocated from Increment_Last calling Reallocate.
 248
 249       subtype Allocated_Table_T is
 250         Table_Type (T.Table'First .. Table_Index_Type (T.P.Max + 1));
 251       --  A constrained table subtype one element larger than the currently
 252       --  allocated table.
 253
 254       Allocated_Table_Address : constant System.Address :=
 255                                   T.Table.all'Address;
 256       --  Used for address clause below (we can't use non-static expression
 257       --  Table.all'Address directly in the clause because some older versions
 258       --  of the compiler do not allow it).
 259
 260       Allocated_Table : Allocated_Table_T;
 261       pragma Import (Ada, Allocated_Table);
 262       pragma Suppress (Range_Check, On => Allocated_Table);
 263       for Allocated_Table'Address use Allocated_Table_Address;
 264       --  Allocated_Table represents the currently allocated array, plus one
 265       --  element (the supplementary element is used to have a convenient way
 266       --  to the address just past the end of the current allocation). Range
 267       --  checks are suppressed because this unit uses direct calls to
 268       --  System.Memory for allocation, and this can yield misaligned storage
 269       --  (and we cannot rely on the bootstrap compiler supporting specifically
 270       --  disabling alignment checks, so we need to suppress all range checks).
 271       --  It is safe to suppress this check here because we know that a
 272       --  (possibly misaligned) object of that type does actually exist at that
 273       --  address.
 274       --  ??? We should really improve the allocation circuitry here to
 275       --  guarantee proper alignment.
 276
 277       Need_Realloc : constant Boolean := Integer (Index) > T.P.Max;
 278       --  True if this operation requires storage reallocation (which may
 279       --  involve moving table contents around).
 280
 281    begin
 282       --  If we're going to reallocate, check whether Item references an
 283       --  element of the currently allocated table.
 284
 285       if Need_Realloc
 286         and then Allocated_Table'Address <= Item'Address
 287         and then Item'Address <
 288                    Allocated_Table (Table_Index_Type (T.P.Max + 1))'Address
 289       then
 290          --  If so, save a copy on the stack because Increment_Last will
 291          --  reallocate storage and might deallocate the current table.
 292
 293          declare
 294             Item_Copy : constant Table_Component_Type := Item;
 295          begin
 296             Set_Last (T, Index);
 297             T.Table (Index) := Item_Copy;
 298          end;
 299
 300       else
 301          --  Here we know that either we won't reallocate (case of Index < Max)
 302          --  or that Item is not in the currently allocated table.
 303
 304          if Integer (Index) > T.P.Last_Val then
 305             Set_Last (T, Index);
 306          end if;
 307
 308          T.Table (Index) := Item;
 309       end if;
 310    end Set_Item;
 311
 312    --------------
 313    -- Set_Last --
 314    --------------
 315
 316    procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type) is
 317    begin
 318       if Integer (New_Val) < T.P.Last_Val then
 319          T.P.Last_Val := Integer (New_Val);
 320
 321       else
 322          T.P.Last_Val := Integer (New_Val);
 323
 324          if T.P.Last_Val > T.P.Max then
 325             Reallocate (T);
 326          end if;
 327       end if;
 328    end Set_Last;
 329
 330    ----------------
 331    -- Sort_Table --
 332    ----------------
 333
 334    procedure Sort_Table (Table : in out Instance) is
 335
 336       Temp : Table_Component_Type;
 337       --  A temporary position to simulate index 0
 338
 339       --  Local subprograms
 340
 341       function Index_Of (Idx : Natural) return Table_Index_Type;
 342       --  Return index of Idx'th element of table
 343
 344       function Lower_Than (Op1, Op2 : Natural) return Boolean;
 345       --  Compare two components
 346
 347       procedure Move (From : Natural; To : Natural);
 348       --  Move one component
 349
 350       package Heap_Sort is new GNAT.Heap_Sort_G (Move, Lower_Than);
 351
 352       --------------
 353       -- Index_Of --
 354       --------------
 355
 356       function Index_Of (Idx : Natural) return Table_Index_Type is
 357          J : constant Integer'Base :=
 358                Table_Index_Type'Pos (First) + Idx - 1;
 359       begin
 360          return Table_Index_Type'Val (J);
 361       end Index_Of;
 362
 363       ----------
 364       -- Move --
 365       ----------
 366
 367       procedure Move (From : Natural; To : Natural) is
 368       begin
 369          if From = 0 then
 370             Table.Table (Index_Of (To)) := Temp;
 371
 372          elsif To = 0 then
 373             Temp := Table.Table (Index_Of (From));
 374
 375          else
 376             Table.Table (Index_Of (To)) :=
 377               Table.Table (Index_Of (From));
 378          end if;
 379       end Move;
 380
 381       ----------------
 382       -- Lower_Than --
 383       ----------------
 384
 385       function Lower_Than (Op1, Op2 : Natural) return Boolean is
 386       begin
 387          if Op1 = 0 then
 388             return Lt (Temp, Table.Table (Index_Of (Op2)));
 389
 390          elsif Op2 = 0 then
 391             return Lt (Table.Table (Index_Of (Op1)), Temp);
 392
 393          else
 394             return
 395               Lt (Table.Table (Index_Of (Op1)),
 396                    Table.Table (Index_Of (Op2)));
 397          end if;
 398       end Lower_Than;
 399
 400    --  Start of processing for Sort_Table
 401
 402    begin
 403       Heap_Sort.Sort (Natural (Last (Table) - First) + 1);
 404    end Sort_Table;
 405
 406 end GNAT.Dynamic_Tables;