Merge branch 'wip/leo_cr/195-arr_limit_fixed' into 'master'

TGen: Reject constrained array types with too many elements

Closes #194

See merge request eng/ide/libadalang-tools!237

src/tgen/tgen-libgen.adb

@@ -49,6 +49,10 @@ with TGen.Types.Translation;  use TGen.Types.Translation;
 
 package body TGen.Libgen is
 
+   Array_Limit_Frozen : Boolean := False;
+   --  If True, calls to Set_Array_Limit will raise a Constraint_Error.
+   --  Should be set by any call to Include_Subp or Supported_Subprogram.
+
    procedure Generate_Support_Library
      (Ctx        : Libgen_Context;
       Pack_Name  : Ada_Qualified_Name) with
@@ -647,6 +651,7 @@ package body TGen.Libgen is
       Trans_Res : constant Translation_Result :=
         Translate (Subp.As_Basic_Decl);
    begin
+      Array_Limit_Frozen := True;
       if Trans_Res.Success then
          Diags := Trans_Res.Res.Get.Get_Diagnostics;
          if Diags.Is_Empty then
@@ -1352,4 +1357,17 @@ package body TGen.Libgen is
          raise;
    end Generate_Harness;
 
+   --------------------------
+   -- Set_Array_Size_Limit --
+   --------------------------
+
+   procedure Set_Array_Size_Limit (Limit : Positive) is
+   begin
+      if Array_Limit_Frozen then
+         raise Constraint_Error with
+           "Attempting to modify array size limit after it has been frozen.";
+      end if;
+      TGen.Marshalling.Set_Array_Size_Limit (Limit);
+   end Set_Array_Size_Limit;
+
 end TGen.Libgen;

src/tgen/tgen-libgen.ads

@@ -33,10 +33,11 @@ with GNATCOLL.VFS;
 with Libadalang.Analysis;
 
 with TGen.Context;
-with TGen.Wrappers;       use TGen.Wrappers;
+with TGen.Marshalling;
+with TGen.Parse_Strategy;    use TGen.Parse_Strategy;
 with TGen.Strings;
-with TGen.Types;          use TGen.Types;
-with TGen.Parse_Strategy; use TGen.Parse_Strategy;
+with TGen.Types;             use TGen.Types;
+with TGen.Wrappers;          use TGen.Wrappers;
 
 package TGen.Libgen is
    package LAL renames Libadalang.Analysis;
@@ -139,6 +140,26 @@ package TGen.Libgen is
    --  generated by the harness under Test_Output_Dir, and will contain
    --  Default_Test_Num tests.
 
+   function Get_Array_Size_Limit return Positive renames
+     TGen.Marshalling.Get_Array_Size_Limit;
+   --  Return the size beyond which the marshallers will give up trying to load
+   --  arrays, to avoid allocating overly-large arrays on the stack.
+   --
+   --  The default value is 1000, but this can be overridden either through the
+   --  TGEN_ARRAY_LIMIT environment variable, or the Set_Array_Size_Limit
+   --  procedure. The latter takes precedence over the former.
+
+   procedure Set_Array_Size_Limit (Limit : Positive);
+   --  Set the array size limit beyond which marshallers will give up reading
+   --  array values, to avoid allocating overly large arrays on the stack.
+   --
+   --  If used, this will override any value set through the TGEN_ARRAY_LIMIT
+   --  environment variable.
+   --
+   --  This can only be called prior to the first call to Include_Subp or
+   --  Supported_Subprogram to ensure consistency of the array limit used in
+   --  all the marshallers, otherwise Constraint_Error is raised.
+
 private
    use TGen.Strings;
    use TGen.Context;

src/tgen/tgen-marshalling.adb

@@ -783,7 +783,7 @@ package body TGen.Marshalling is
                  5  => Assoc ("COMP_PREFIX", Comp_Pref_Tag),
                  6  => Assoc ("ADA_DIM", Ada_Dim_Tag),
                  7  => Assoc ("IS_ENUM", Is_Enum_Tag),
-                 8  => Assoc ("ARR_LIMIT", Array_Length_Limit)];
+                 8  => Assoc ("ARR_LIMIT", Get_Array_Size_Limit)];
 
          begin
             Print_Header (Assocs);
@@ -1134,6 +1134,21 @@ package body TGen.Marshalling is
       Append (Str.all, Ada.Characters.Latin_1.LF);
    end New_Line;
 
+   --------------------------
+   -- Get_Array_Size_Limit --
+   --------------------------
+
+   function Get_Array_Size_Limit return Positive is (Array_Length_Limit);
+
+   --------------------------
+   -- Set_Array_Size_Limit --
+   --------------------------
+
+   procedure Set_Array_Size_Limit (Limit : Positive) is
+   begin
+      Array_Length_Limit := Limit;
+   end Set_Array_Size_Limit;
+
 begin
 
    if Ada.Environment_Variables.Exists (Array_Length_Limit_Env_Var) then

src/tgen/tgen-marshalling.ads

@@ -47,6 +47,21 @@ package TGen.Marshalling is
    function Input_Fname_For_Typ (Typ_FQN : Ada_Qualified_Name) return String;
    --  Name of the input marshalling function for the given type
 
+   function Get_Array_Size_Limit return Positive;
+   --  Return the size beyond which the marshallers will give up trying to load
+   --  arrays, to avoid allocating overly-large arrays on the stack.
+   --
+   --  The default value is 1000, but this can be overridden either through the
+   --  TGEN_ARRAY_LIMIT environment variable, or the Set_Array_Size_Limit
+   --  procedure. The latter takes precedence over the former.
+
+   procedure Set_Array_Size_Limit (Limit : Positive);
+   --  Set the array size limit beyond which marshallers will give up reading
+   --  array values, to avoid allocating overly large arrays on the stack.
+   --
+   --  If used, this will override any value set through the TGEN_ARRAY_LIMIT
+   --  environment variable.
+
    Global_Prefix   : constant String := "TGen_Marshalling";
 
    type Spec_Part is (Pub, Priv);

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)
@@ -2963,7 +3025,7 @@ package body TGen.Types.Translation is
       --  First part of the declaration. Used to determine whether the type we
       --  are translating is private or not.
 
-      Specialized_Res : Translation_Result (Success => True);
+      Specialized_Res : Translation_Result;
 
    begin
       Verbose_Diag := Verbose;
@@ -2980,6 +3042,8 @@ package body TGen.Types.Translation is
          --  declarations or anonymous access types, both of which we don't
          --  intend to support.
 
+         Specialized_Res := (Success => True, others => <>);
+
          Specialized_Res.Res.Set
            (Unsupported_Typ'
              (Reason => To_Unbounded_String
@@ -2993,6 +3057,7 @@ package body TGen.Types.Translation is
          --  modular integer but for which we do not want to generate any
          --  values.
 
+         Specialized_Res := (Success => True, others => <>);
          Specialized_Res.Res.Set (Unsupported_Typ'
            (Reason => To_Unbounded_String ("System.Address unsupported"),
             others => <>));
@@ -3002,13 +3067,15 @@ package body TGen.Types.Translation is
          --  We are dealing with a private type declared in a nested package,
          --  consider this as unsupported.
 
+         Specialized_Res := (Success => True, others => <>);
          Specialized_Res.Res.Set (Unsupported_Typ'
            (Reason =>
               To_Unbounded_String
                 ("Private types declared in nested package are not"
                  & " supported"),
             others => <>));
       elsif Root_Type.P_Is_Formal then
+         Specialized_Res := (Success => True, others => <>);
          Specialized_Res.Res.Set (Formal_Typ'
            (Reason =>
               To_Unbounded_String ("Generic formal types are unsupported"),
@@ -3020,10 +3087,12 @@ package body TGen.Types.Translation is
           (Node       => N,
            Other_Type => N.P_Bool_Type.As_Base_Type_Decl)
       then
+         Specialized_Res := (Success => True, others => <>);
          Specialized_Res.Res.Set (Bool_Typ'(Is_Static => True, others => <>));
       elsif Root_Type.P_Is_Enum_Type then
 
          if not Is_Static then
+            Specialized_Res := (Success => True, others => <>);
             Specialized_Res.Res.Set (Other_Enum_Typ'
               (Is_Static => False, others => <>));
          end if;
@@ -3045,6 +3114,7 @@ package body TGen.Types.Translation is
          if Is_Static then
             Specialized_Res := Translate_Float_Decl (N);
          else
+            Specialized_Res := (Success => True, others => <>);
             Specialized_Res.Res.Set
               (Float_Typ'
                (Is_Static => False,
@@ -3059,6 +3129,7 @@ package body TGen.Types.Translation is
             if Is_Static then
                Specialized_Res := Translate_Ordinary_Fixed_Decl (N);
             else
+               Specialized_Res := (Success => True, others => <>);
                Specialized_Res.Res.Set
                  (Ordinary_Fixed_Typ'
                     (Is_Static => False,
@@ -3068,6 +3139,7 @@ package body TGen.Types.Translation is
             if Is_Static then
                Specialized_Res := Translate_Decimal_Fixed_Decl (N);
             else
+               Specialized_Res := (Success => True, others => <>);
                Specialized_Res.Res.Set
                  (Decimal_Fixed_Typ'
                     (Is_Static => False,
@@ -3081,6 +3153,7 @@ package body TGen.Types.Translation is
 
       elsif Root_Type.P_Is_Record_Type then
          if Root_Type.P_Is_Tagged_Type then
+            Specialized_Res := (Success => True, others => <>);
             Specialized_Res.Res.Set
               (Unsupported_Typ'
                 (Reason => To_Unbounded_String ("tagged types not supported"),
@@ -3090,12 +3163,14 @@ package body TGen.Types.Translation is
          end if;
 
       elsif Root_Type.P_Is_Access_Type then
+         Specialized_Res := (Success => True, others => <>);
          Specialized_Res.Res.Set
            (Access_Typ'
               (Reason =>
                  To_Unbounded_String ("Access types are not supported"),
                others => <>));
       else
+         Specialized_Res := (Success => True, others => <>);
          Specialized_Res.Res.Set
            (Unsupported_Typ'
               (Reason => To_Unbounded_String ("Unknown type kind"),