with Spark_Unbound.Safe_Alloc;
with AUnit.Assertions; use AUnit.Assertions;
with Ada.Exceptions;
package body SA_Arrays_Tests is
procedure TestAlloc_WithForcingStorageError_ResultNullReturned(T : in out Test_Fixture)
is
type Array_Type is array (Integer range <>) of Integer;
type Array_Acc is access Array_Type;
package Int_Arrays is new Spark_Unbound.Safe_Alloc.Arrays(Element_Type => Integer, Index_Type => Integer, Array_Type => Array_Type, Array_Type_Acc => Array_Acc);
Arr_Acc : Array_Acc;
Array_Last : Integer := 1_000_000_000;
Storage_Error_Forced : Boolean := False;
-- table to keep track of allocated arrays to be freed later
type Acc_Table_Array is array (Integer range <>) of Array_Acc;
Acc_Table : Acc_Table_Array(0 .. 1_000_000);
Table_Index : Integer := Acc_Table'First;
begin
declare
begin
loop
exit when (Storage_Error_Forced or else Table_Index >= Acc_Table'Last);
begin
Arr_Acc := Int_Arrays.Alloc(First => Integer'First, Last => Array_Last);
begin
Acc_Table(Table_Index) := Arr_Acc;
Table_Index := Table_Index + 1;
exception
when others =>
Assert(False, "Table append failed");
end;
if Arr_Acc = null then
Storage_Error_Forced := True;
elsif Array_Last < Integer'Last - Array_Last then
Array_Last := Array_Last + Array_Last;
else
Array_Last := Integer'Last;
end if;
exception
when E : others =>
Assert(False, "Alloc failed: " & Ada.Exceptions.Exception_Name(E) & " => " & Ada.Exceptions.Exception_Message(E));
end;
end loop;
-- free allocated
for I in Acc_Table'First .. Acc_Table'Last loop
Int_Arrays.Free(Acc_Table(I));
end loop;
Assert(Storage_Error_Forced, "Storage_Error could not be forced. Last value = " & Array_Last'Image);
exception
when E : others =>
Assert(False, "Exception got raised with Last = " & Array_Last'Image & " Reason: " & Ada.Exceptions.Exception_Name(E) & " => " & Ada.Exceptions.Exception_Message(E));
end;
end TestAlloc_WithForcingStorageError_ResultNullReturned;
end SA_Arrays_Tests;