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-2006, 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 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 Unchecked_Conversion (Table_Ptr, Address);
  59    function To_Pointer is new 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       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    -- For_Each --
 100    --------------
 101
 102    procedure For_Each (Table : Instance) is
 103       Quit : Boolean := False;
 104    begin
 105       for Index in Table_Low_Bound .. Table_Index_Type (Table.P.Last_Val) loop
 106          Action (Index, Table.Table (Index), Quit);
 107          exit when Quit;
 108       end loop;
 109    end For_Each;
 110
 111    ----------
 112    -- Free --
 113    ----------
 114
 115    procedure Free (T : in out Instance) is
 116    begin
 117       Free (To_Address (T.Table));
 118       T.Table := null;
 119       T.P.Length := 0;
 120    end Free;
 121
 122    --------------------
 123    -- Increment_Last --
 124    --------------------
 125
 126    procedure Increment_Last (T : in out Instance) is
 127    begin
 128       T.P.Last_Val := T.P.Last_Val + 1;
 129
 130       if T.P.Last_Val > T.P.Max then
 131          Reallocate (T);
 132       end if;
 133    end Increment_Last;
 134
 135    ----------
 136    -- Init --
 137    ----------
 138
 139    procedure Init (T : in out Instance) is
 140       Old_Length : constant Integer := T.P.Length;
 141
 142    begin
 143       T.P.Last_Val := Min - 1;
 144       T.P.Max      := Min + Table_Initial - 1;
 145       T.P.Length   := T.P.Max - Min + 1;
 146
 147       --  If table is same size as before (happens when table is never
 148       --  expanded which is a common case), then simply reuse it. Note
 149       --  that this also means that an explicit Init call right after
 150       --  the implicit one in the package body is harmless.
 151
 152       if Old_Length = T.P.Length then
 153          return;
 154
 155       --  Otherwise we can use Reallocate to get a table of the right size.
 156       --  Note that Reallocate works fine to allocate a table of the right
 157       --  initial size when it is first allocated.
 158
 159       else
 160          Reallocate (T);
 161       end if;
 162    end Init;
 163
 164    ----------
 165    -- Last --
 166    ----------
 167
 168    function Last (T : Instance) return Table_Index_Type is
 169    begin
 170       return Table_Index_Type (T.P.Last_Val);
 171    end Last;
 172
 173    ----------------
 174    -- Reallocate --
 175    ----------------
 176
 177    procedure Reallocate (T : in out Instance) is
 178       New_Length : Integer;
 179       New_Size   : size_t;
 180
 181    begin
 182       if T.P.Max < T.P.Last_Val then
 183          while T.P.Max < T.P.Last_Val loop
 184             New_Length := T.P.Length * (100 + Table_Increment) / 100;
 185
 186             if New_Length > T.P.Length then
 187                T.P.Length := New_Length;
 188             else
 189                T.P.Length := T.P.Length + 1;
 190             end if;
 191
 192             T.P.Max := Min + T.P.Length - 1;
 193          end loop;
 194       end if;
 195
 196       New_Size :=
 197         size_t ((T.P.Max - Min + 1) *
 198                 (Table_Type'Component_Size / Storage_Unit));
 199
 200       if T.Table = null then
 201          T.Table := To_Pointer (Alloc (New_Size));
 202
 203       elsif New_Size > 0 then
 204          T.Table :=
 205            To_Pointer (Realloc (Ptr  => To_Address (T.Table),
 206                                 Size => New_Size));
 207       end if;
 208
 209       if T.P.Length /= 0 and then T.Table = null then
 210          raise Storage_Error;
 211       end if;
 212    end Reallocate;
 213
 214    -------------
 215    -- Release --
 216    -------------
 217
 218    procedure Release (T : in out Instance) is
 219    begin
 220       T.P.Length := T.P.Last_Val - Integer (Table_Low_Bound) + 1;
 221       T.P.Max    := T.P.Last_Val;
 222       Reallocate (T);
 223    end Release;
 224
 225    --------------
 226    -- Set_Item --
 227    --------------
 228
 229    procedure Set_Item
 230      (T     : in out Instance;
 231       Index : Table_Index_Type;
 232       Item  : Table_Component_Type)
 233    is
 234    begin
 235       if Integer (Index) > T.P.Last_Val then
 236          Set_Last (T, Index);
 237       end if;
 238
 239       T.Table (Index) := Item;
 240    end Set_Item;
 241
 242    --------------
 243    -- Set_Last --
 244    --------------
 245
 246    procedure Set_Last (T : in out Instance; New_Val : Table_Index_Type) is
 247    begin
 248       if Integer (New_Val) < T.P.Last_Val then
 249          T.P.Last_Val := Integer (New_Val);
 250
 251       else
 252          T.P.Last_Val := Integer (New_Val);
 253
 254          if T.P.Last_Val > T.P.Max then
 255             Reallocate (T);
 256          end if;
 257       end if;
 258    end Set_Last;
 259
 260    ----------------
 261    -- Sort_Table --
 262    ----------------
 263
 264    procedure Sort_Table (Table : in out Instance) is
 265
 266       Temp : Table_Component_Type;
 267       --  A temporary position to simulate index 0
 268
 269       --  Local subprograms
 270
 271       function Index_Of (Idx : Natural) return Table_Index_Type;
 272       --  Apply Natural to indexs of the table
 273
 274       function Lower_Than (Op1, Op2 : Natural) return Boolean;
 275       --  Compare two components
 276
 277       procedure Move (From : Natural; To : Natural);
 278       --  Move one component
 279
 280       package Heap_Sort is new GNAT.Heap_Sort_G (Move, Lower_Than);
 281
 282       --------------
 283       -- Index_Of --
 284       --------------
 285
 286       function Index_Of (Idx : Natural) return Table_Index_Type is
 287          J : constant Integer'Base :=
 288                Table_Index_Type'Pos (First) + Idx - 1;
 289       begin
 290          return Table_Index_Type'Val (J);
 291       end Index_Of;
 292
 293       ----------
 294       -- Move --
 295       ----------
 296
 297       procedure Move (From : Natural; To : Natural) is
 298       begin
 299          if From = 0 then
 300             Table.Table (Index_Of (To)) := Temp;
 301
 302          elsif To = 0 then
 303             Temp := Table.Table (Index_Of (From));
 304
 305          else
 306             Table.Table (Index_Of (To)) :=
 307               Table.Table (Index_Of (From));
 308          end if;
 309       end Move;
 310
 311       ----------------
 312       -- Lower_Than --
 313       ----------------
 314
 315       function Lower_Than (Op1, Op2 : Natural) return Boolean is
 316       begin
 317          if Op1 = 0 then
 318             return Lt (Temp, Table.Table (Index_Of (Op2)));
 319
 320          elsif Op2 = 0 then
 321             return Lt (Table.Table (Index_Of (Op1)), Temp);
 322
 323          else
 324             return
 325               Lt (Table.Table (Index_Of (Op1)),
 326                    Table.Table (Index_Of (Op2)));
 327          end if;
 328       end Lower_Than;
 329
 330    --  Start of processing for Sort_Table
 331
 332    begin
 333       Heap_Sort.Sort (Natural (Last (Table) - First) + 1);
 334    end Sort_Table;
 335
 336 end GNAT.Dynamic_Tables;