TGen: Reject constrained array types with too many elements

TGen already rejected at runtime unconstrained array values exceeding
a configurable limit.

With this change, constrained array types are also rejected when they
define a type with more elements than the configured limit.

src/tgen/tgen-types-translation.adb

@@ -42,6 +42,7 @@ with TGen.Types.Enum_Types;      use TGen.Types.Enum_Types;
 with TGen.Types.Int_Types;       use TGen.Types.Int_Types;
 with TGen.Types.Real_Types;      use TGen.Types.Real_Types;
 with TGen.Types.Record_Types;    use TGen.Types.Record_Types;
+with TGen.Marshalling;
 with TGen.Numerics;
 
 package body TGen.Types.Translation is
@@ -1220,6 +1221,7 @@ package body TGen.Types.Translation is
             Decl.P_Root_Type.P_Full_View.As_Type_Decl.F_Type_Def
             .As_Array_Type_Def.F_Component_Type;
          Num_Indices : Natural := 0;
+         Total_Size  : Big_Integer;
       begin
          --  Compute the number of indices
 
@@ -1355,9 +1357,6 @@ package body TGen.Types.Translation is
                end if;
 
                if not Has_Constraints then
-                  Res_Typ.Index_Constraints (Current_Index) :=
-                    (Present => False);
-
                   --  Check if the index type is a subtype with constraints. If
                   --  this is the case, update the constraints accordingly.
 
@@ -1368,6 +1367,9 @@ package body TGen.Types.Translation is
                             (Constraint.As_Identifier.P_Referenced_Decl
                              .As_Base_Type_Decl);
                      begin
+
+                        --  Create non-static constraints by default...
+
                         if Id_Type_Res.Success then
                            declare
                               FQN : constant String :=
@@ -1386,19 +1388,30 @@ package body TGen.Types.Translation is
                                  Max_Text := +(FQN & "'Last");
                               end if;
                            end;
-                           Res_Typ.Index_Constraints (Current_Index) :=
-                             (Present    => True,
-                              Discrete_Range =>
-                                (Low_Bound  =>
-                                   (Kind => Non_Static,
-                                    Text => +Min_Text),
-                                 High_Bound =>
-                                   (Kind => Non_Static,
-                                    Text => +Max_Text)));
-                        end if;
+                           Has_Constraints := True;
+                           Min_Static := False;
+                           Max_Static := False;
 
+                           --  ...But attempt to evaluate the subtype bounds,
+                           --  this is still useful in practice to detect
+                           --  arrays that could be too large.
+
+                           if As_Discrete_Typ (Id_Type_Res.Res).Is_Static then
+                              Min_Static := True;
+                              Max_Static := True;
+                              Constraint_Min :=
+                                As_Discrete_Typ (Id_Type_Res.Res).Low_Bound;
+                              Constraint_Max :=
+                                As_Discrete_Typ (Id_Type_Res.Res).High_Bound;
+                           end if;
+                        end if;
                      end;
                   end if;
+               end if;
+
+               if not Has_Constraints then
+                  Res_Typ.Index_Constraints (Current_Index) :=
+                    (Present => False);
                elsif Max_Static and then not Min_Static then
                   Res_Typ.Index_Constraints (Current_Index) :=
                   (Present        => True,
@@ -1440,6 +1453,28 @@ package body TGen.Types.Translation is
               and then (for all Idx in 1 .. Res_Typ.Num_Dims
                           => Static (Res_Typ.Index_Constraints (Idx)));
 
+            --  Check if the translated array type has less elements than what
+            --  is allowed.
+
+            Total_Size := Res_Typ.Size;
+            if Total_Size >
+              To_Big_Integer (TGen.Marshalling.Get_Array_Size_Limit)
+            then
+               return Res : Translation_Result (Success => True) do
+                  Res.Res.Set
+                    (Unsupported_Typ'
+                       (Reason =>
+                        +("array type " & To_Ada (Res_Typ.Name)
+                          & "has more elements ("
+                          & Trim (To_String (Total_Size))
+                          & ") than the configured limit ("
+                          & Trim (Positive'Image
+                              (TGen.Marshalling.Get_Array_Size_Limit))
+                          & ")"),
+                        others => <>));
+               end return;
+            end if;
+
             return Res : Translation_Result (Success => True) do
                Res.Res.Set (Res_Typ);
             end return;
@@ -2832,9 +2867,15 @@ package body TGen.Types.Translation is
                       (N.As_Subtype_Indication.F_Constraint))));
             end return;
          when Array_Typ_Range =>
-            return Res : Translation_Result (Success => True) do
-               Res.Res.Set (Anonymous_Typ'
-                 (Name                => Ada_Identifier_Vectors.Empty_Vector,
+
+               --  We need to check wether this anonymous array type isn't
+               --  going to be larger than what is supported by the
+               --  marshallers.
+
+            declare
+               Anon_Typ : constant Anonymous_Typ :=
+                 (Name                =>
+                    Ada_Identifier_Vectors.Empty_Vector,
                   Last_Comp_Unit_Idx  => 1,
                   Named_Ancestor      => Intermediate_Result.Res,
                   Fully_Private       =>
@@ -2843,10 +2884,31 @@ package body TGen.Types.Translation is
                     Intermediate_Result.Res.Get.Private_Extension,
                   Subtype_Constraints => new Index_Constraints'
                     (Translate_Index_Constraints
-                      (N.As_Subtype_Indication.F_Constraint,
-                       As_Unconstrained_Array_Typ
-                         (Intermediate_Result.Res).Num_Dims))));
-            end return;
+                       (N.As_Subtype_Indication.F_Constraint,
+                        As_Unconstrained_Array_Typ
+                          (Intermediate_Result.Res).Num_Dims)));
+
+               Total_Size : constant Big_Integer :=
+                 As_Constrained_Array_Typ (Anon_Typ.As_Named_Typ).Size;
+            begin
+               if Total_Size >
+                 To_Big_Integer (TGen.Marshalling.Get_Array_Size_Limit)
+               then
+                  return Res : Translation_Result (Success => False) do
+                     Res.Diagnostics :=
+                       +("array type has more elements ("
+                         & Trim (To_String (Total_Size))
+                         & ") than the configured limit ("
+                         & Trim (Positive'Image
+                             (TGen.Marshalling.Get_Array_Size_Limit))
+                         & ")");
+                  end return;
+               else
+                  return Res : Translation_Result (Success => True) do
+                     Res.Res.Set (Anon_Typ);
+                  end return;
+               end if;
+            end;
          when Record_Typ_Range =>
             return Res : Translation_Result (Success => True) do
                pragma Assert (Kind (N.As_Subtype_Indication.F_Constraint)

src/tgen/tgen_rts/tgen-types-array_types.adb

@@ -113,6 +113,43 @@ package body TGen.Types.Array_Types is
       return To_String (Res);
    end Image;
 
+   ----------
+   -- Size --
+   ----------
+
+   function Size (Self : Constrained_Array_Typ) return Big_Integer is
+      Total_Size  : Big_Integer := To_Big_Integer (1);
+   begin
+      for I in 1 .. Self.Num_Dims loop
+         if not Self.Index_Constraints (I).Present then
+            if As_Discrete_Typ (Self.Index_Types (I)).Is_Static then
+               Total_Size := Total_Size *
+                 (As_Discrete_Typ (Self.Index_Types (I)).High_Bound
+                  - As_Discrete_Typ (Self.Index_Types (I)).Low_Bound
+                  + To_Big_Integer (1));
+            else
+               Total_Size := To_Big_Integer (-1);
+            end if;
+         elsif Self.Index_Constraints (I).Discrete_Range.High_Bound.Kind
+               = Static
+              and then Self.Index_Constraints (I).Discrete_Range.Low_Bound.Kind
+                       = Static
+         then
+            Total_Size := Total_Size *
+              (Self.Index_Constraints (I).Discrete_Range.High_Bound.Int_Val
+               - Self.Index_Constraints (I).Discrete_Range.Low_Bound.Int_Val
+               + To_Big_Integer (1));
+         else
+            Total_Size := To_Big_Integer (-1);
+         end if;
+      end loop;
+      return Total_Size;
+   end Size;
+
+   ----------------------------
+   -- Callback_On_Constraint --
+   ----------------------------
+
    procedure Callback_On_Constraint
      (Self     : Constrained_Array_Typ;
       Var_Name : Unbounded_String;

src/tgen/tgen_rts/tgen-types-array_types.ads

@@ -104,6 +104,10 @@ package TGen.Types.Array_Types is
      (Self : Constrained_Array_Typ) return Strategy_Type'Class;
    --  Generate a strategy for the generation for a Constrained_Array_Typ
 
+   function Size (Self : Constrained_Array_Typ) return Big_Integer;
+   --  Return the size, in number of elements, of self, if all indices are
+   --  static. Return an unspecified negative value otherwise.
+
    type Constr_Array_Enum_Strat is new Enum_Strategy_Type with record
       Arr_T : SP.Ref;
       --  Type of the array for which we are generating values

testsuite/tests/test/194_const_array_limit/pkg.ads

@@ -0,0 +1,26 @@
+package Pkg is
+
+   type Long_Array is array (Integer range 1 .. Integer'Last) of Integer;
+
+   type Long_Array_2 is array (Integer) of Integer;
+
+   subtype Large_Int is Positive range 1 .. 100000;
+
+   subtype Long_Array_3 is String (Large_Int);
+
+   type Big_Rec is record
+      Long_Component : String (Large_Int);
+   end record;
+
+   function First (Arr : Long_Array) return Integer is (Arr (1));
+
+   function First (Arr : Long_Array_2) return Integer is (Arr (Integer'First));
+
+   function First (Arr : Long_Array_3) return Character is (Arr (1));
+
+   function First (X : Big_Rec) return Character is (X.Long_Component (1));
+
+   function Dummy (X : Positive) return Positive is (X);
+   --  Just here so there is something to generate.
+
+end Pkg;

testsuite/tests/test/194_const_array_limit/prj.gpr

@@ -0,0 +1,5 @@
+project Prj is
+
+   for Object_Dir use "obj";
+
+end Prj;

testsuite/tests/test/194_const_array_limit/test.out

@@ -0,0 +1,23 @@
+gnattest: Error while processing <ExprFunction ["First"] pkg.ads:15:4-15:66>:
+pkg.first.Arr: pkg.long_array is not supported (array type has more elements (2147483647) than the configured limit (1000))
+
+gnattest: Error while processing <ExprFunction ["First"] pkg.ads:17:4-17:80>:
+pkg.first.Arr: pkg.long_array_2 is not supported (array type has more elements (4294967296) than the configured limit (1000))
+
+gnattest: Error while processing <ExprFunction ["First"] pkg.ads:19:4-19:70>:
+pkg.first.Arr: pkg.long_array_3 is not supported (array type has more elements (100000) than the configured limit (1000))
+
+gnattest: Error while processing <ExprFunction ["First"] pkg.ads:21:4-21:76>:
+Failed to translate type of component<ComponentDecl ["Long_Component"] pkg.ads:12:7-12:43>: array type has more elements (100000) than the configured limit (1000)
+
+pkg.ads:23:4: info: corresponding test PASSED
+pkg.ads:23:4: info: corresponding test PASSED
+pkg.ads:23:4: info: corresponding test PASSED
+pkg.ads:23:4: info: corresponding test PASSED
+pkg.ads:23:4: info: corresponding test PASSED
+pkg.ads:15:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:45)
+pkg.ads:17:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:66)
+pkg.ads:19:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:87)
+pkg.ads:21:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:108)
+pkg.ads:23:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:129)
+10 tests run: 5 passed; 5 failed; 0 crashed.

testsuite/tests/test/194_const_array_limit/test.sh

@@ -0,0 +1,5 @@
+#!/bin/bash
+
+gnattest -P prj.gpr --gen-test-vectors
+gprbuild -P obj/gnattest/harness/test_driver.gpr -q
+./obj/gnattest/harness/test_runner

testsuite/tests/test/194_const_array_limit/test.yaml

@@ -0,0 +1,10 @@
+description:
+  Check that TGen properly rejects constrained array types which are over the
+  configured array size limit.
+  We do this by attempting to generate tests with gnattest for a big array type,
+  and checking the emitted warnings.
+
+driver: shell_script
+
+control:
+    - [XFAIL, 'x86', 'Marshalling not working for 32bits (UB03-008)']