with Spark_Unbound.Safe_Alloc;
with AUnit.Assertions; use AUnit.Assertions;
with Ada.Exceptions;
package body SA_Definite_Tests is
procedure TestAlloc_WithForcingStorageError_ResultNullReturned(T : in out Test_Fixture)
is
-- type Inner_Array is array(-90 .. 90) of Integer; -- forced test fail
type Inner_Array is array(-9_00_000_000 .. 9_00_000_000) of Integer;
type Alloc_Record is record
Arr1 : Inner_Array;
Arr2 : Inner_Array;
Arr3 : Inner_Array;
Arr4 : Inner_Array;
Arr5 : Inner_Array;
Arr6 : Inner_Array;
Arr7 : Inner_Array;
Arr8 : Inner_Array;
Arr9 : Inner_Array;
Arr10 : Inner_Array;
Arr11 : Inner_Array;
Arr12 : Inner_Array;
Arr13 : Inner_Array;
Arr14 : Inner_Array;
Arr15 : Inner_Array;
Arr16 : Inner_Array;
Arr17 : Inner_Array;
Arr18 : Inner_Array;
Arr19 : Inner_Array;
Arr20 : Inner_Array;
V1 : Integer;
V2 : Natural;
V3 : Positive;
end record;
type Record_Acc is access Alloc_Record;
package Record_Alloc is new Spark_Unbound.Safe_Alloc.Definite(T => Alloc_Record, T_Acc => Record_Acc);
Rec_Acc : Record_Acc;
Storage_Error_Forced : Boolean := False;
-- table to keep track of allocated records to be freed later
type Rec_Table_Array is array (Integer range <>) of Record_Acc;
Rec_Table : Rec_Table_Array(0 .. 1_000_000);
Table_Index : Integer := Rec_Table'First;
begin
declare
begin
loop
exit when (Storage_Error_Forced or else Table_Index >= Rec_Table'Last);
begin
Rec_Acc := Record_Alloc.Alloc;
begin
Rec_Table(Table_Index) := Rec_Acc;
Table_Index := Table_Index + 1;
exception
when others =>
Assert(False, "Table append failed");
end;
if Rec_Acc = null then
Storage_Error_Forced := True;
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 Rec_Table'First .. Rec_Table'Last loop
Record_Alloc.Free(Rec_Table(I));
end loop;
Assert(Storage_Error_Forced, "Storage_Error could not be forced");
exception
when E : others =>
Assert(False, "Exception got raised! Reason: " & Ada.Exceptions.Exception_Name(E) & " => " & Ada.Exceptions.Exception_Message(E));
end;
end TestAlloc_WithForcingStorageError_ResultNullReturned;
end SA_Definite_Tests;