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