spark_unbound_0.2.1_1f8dae01/tests/src/Safe_Alloc/sa_arrays_tests.adb

 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
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;