with Debug; use Debug;
with Opt;
with Output; use Output;
pragma Elaborate_All (Output);
with System; use System;
with Tree_IO; use Tree_IO;
with System.Memory; use System.Memory;
with System.Address_To_Access_Conversions;
package body Table is
package body Table is
Min : constant Int := Int (Table_Low_Bound);
Length : Int := 0;
procedure Reallocate;
function Tree_Get_Table_Address return Address;
package Table_Conversions is
new System.Address_To_Access_Conversions (Big_Table_Type);
function To_Address (Table : Table_Ptr) return Address;
pragma Inline (To_Address);
function To_Pointer (Table : Address) return Table_Ptr;
pragma Inline (To_Pointer);
procedure Append (New_Val : Table_Component_Type) is
begin
Increment_Last;
Table (Table_Index_Type (Last_Val)) := New_Val;
end Append;
procedure Decrement_Last is
begin
Last_Val := Last_Val - 1;
end Decrement_Last;
procedure Free is
begin
Free (To_Address (Table));
Table := null;
Length := 0;
end Free;
procedure Increment_Last is
begin
Last_Val := Last_Val + 1;
if Last_Val > Max then
Reallocate;
end if;
end Increment_Last;
procedure Init is
Old_Length : Int := Length;
begin
Last_Val := Min - 1;
Max := Min + (Table_Initial * Opt.Table_Factor) - 1;
Length := Max - Min + 1;
if Old_Length = Length then
return;
else
Reallocate;
end if;
end Init;
function Last return Table_Index_Type is
begin
return Table_Index_Type (Last_Val);
end Last;
procedure Reallocate is
New_Size : Memory.size_t;
begin
if Max < Last_Val then
pragma Assert (not Locked);
Length := Int'Max (Length, Table_Initial);
while Max < Last_Val loop
Length := Length * (100 + Table_Increment) / 100;
Max := Min + Length - 1;
end loop;
if Debug_Flag_D then
Write_Str ("--> Allocating new ");
Write_Str (Table_Name);
Write_Str (" table, size = ");
Write_Int (Max - Min + 1);
Write_Eol;
end if;
end if;
New_Size :=
Memory.size_t ((Max - Min + 1) *
(Table_Type'Component_Size / Storage_Unit));
if Table = null then
Table := To_Pointer (Alloc (New_Size));
elsif New_Size > 0 then
Table :=
To_Pointer (Realloc (Ptr => To_Address (Table),
Size => New_Size));
end if;
if Length /= 0 and then Table = null then
Set_Standard_Error;
Write_Str ("available memory exhausted");
Write_Eol;
Set_Standard_Output;
raise Unrecoverable_Error;
end if;
end Reallocate;
procedure Release is
begin
Length := Last_Val - Int (Table_Low_Bound) + 1;
Max := Last_Val;
Reallocate;
end Release;
procedure Restore (T : Saved_Table) is
begin
Free (To_Address (Table));
Last_Val := T.Last_Val;
Max := T.Max;
Table := T.Table;
Length := Max - Min + 1;
end Restore;
function Save return Saved_Table is
Res : Saved_Table;
begin
Res.Last_Val := Last_Val;
Res.Max := Max;
Res.Table := Table;
Table := null;
Length := 0;
Init;
return Res;
end Save;
procedure Set_Item
(Index : Table_Index_Type;
Item : Table_Component_Type)
is
begin
if Int (Index) > Max then
Set_Last (Index);
end if;
Table (Index) := Item;
end Set_Item;
procedure Set_Last (New_Val : Table_Index_Type) is
begin
if Int (New_Val) < Last_Val then
Last_Val := Int (New_Val);
else
Last_Val := Int (New_Val);
if Last_Val > Max then
Reallocate;
end if;
end if;
end Set_Last;
function To_Address (Table : Table_Ptr) return Address is
begin
return Table_Conversions.To_Address
(Table_Conversions.Object_Pointer (Table));
end To_Address;
function To_Pointer (Table : Address) return Table_Ptr is
begin
return Table_Ptr (Table_Conversions.To_Pointer (Table));
end To_Pointer;
function Tree_Get_Table_Address return Address is
begin
if Length = 0 then
return Null_Address;
else
return Table (First)'Address;
end if;
end Tree_Get_Table_Address;
procedure Tree_Read is
begin
Tree_Read_Int (Max);
Last_Val := Max;
Length := Max - Min + 1;
Reallocate;
Tree_Read_Data
(Tree_Get_Table_Address,
(Last_Val - Int (First) + 1) *
Table_Type'Component_Size / Storage_Unit);
end Tree_Read;
procedure Tree_Write is
begin
Tree_Write_Int (Int (Last));
Tree_Write_Data
(Tree_Get_Table_Address,
(Last_Val - Int (First) + 1) *
Table_Type'Component_Size / Storage_Unit);
end Tree_Write;
begin
Init;
end Table;
end Table;