Merge branch 'leo/151-array_limit' into 'master'

TGen: Add array size limit beyond which marshallers do not attempt to load them

Closes #151

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

share/tgen/templates/marshalling_templates/header_body.tmplt

@@ -5,10 +5,14 @@
 @@--  @_FIRST_NAME_@ Names of the components for the 'First attributes. Only
 @@--       set if the current type is an array.
 @@--  @_LAST_NAME_@ Same as above for the 'Last attributes.
+@@--  @_COMP_TYP_@ Type name of the index type or discriminant type
 @@--  @_ADA_DIM_@ Suffixes of the array attributes for each dimension.
 @@--  @_DISCR_NAME_@ Same as above for the discriminants of records.
 @@--  @_COMP_PREFIX_@ Prefixes used for all entity of the index types
 @@--       for arrays, and of the discriminants for records.
+@@--  @_IS_ENUM_@ Boolean, indicates if the index type is an enumerated type
+@@--  @_ARR_LIMIT_@ Number of elements in one dimension beyond which the array
+@@--       instantiation should not be done.
 @@--
 @@INCLUDE@@ util.tmplt
    --  Input and Output subprograms for headers of type @_TY_NAME_@
@@ -68,6 +72,26 @@
       return @_TY_NAME_@
    is
    begin
+@@IF@@ @_FIRST_NAME_@ /= ""
+@@TABLE@@
+      declare
+         use type @_COMP_TYP_@;
+         HB : @_COMP_TYP_@ renames @_GLOBAL_PREFIX_@_H.@_LAST_NAME_@;
+         LB : @_COMP_TYP_@ renames @_GLOBAL_PREFIX_@_H.@_FIRST_NAME_@;
+      begin
+@@IF@@ @_IS_ENUM_@
+         if @_COMP_TYP_@'Pos (HB) > @_COMP_TYP_@'Pos (LB)
+           and then Biggest_Int (@_COMP_TYP_@'Pos (HB) - @_COMP_TYP_@'Pos (LB))
+                  > @_ARR_LIMIT_@
+@@ELSE@@
+         if HB > LB and then Biggest_Int (HB - LB) > @_ARR_LIMIT_@
+@@END_IF@@
+         then
+            raise TGen.Marshalling_Lib.Invalid_Value;
+         end if;
+      end;
+@@END_TABLE@@
+@@END_IF@@
       pragma Warnings (Off, "variable ""@_GLOBAL_PREFIX_@_V"" is read but never assigned");
       return @_GLOBAL_PREFIX_@_V : @_TY_NAME_@
 @@IF@@ @_FIRST_NAME_@ /= ""

src/tgen/tgen-marshalling.adb

@@ -22,6 +22,7 @@
 ------------------------------------------------------------------------------
 
 with Ada.Characters.Latin_1;
+with Ada.Environment_Variables;
 with Ada.Numerics.Big_Numbers.Big_Integers;
 use  Ada.Numerics.Big_Numbers.Big_Integers;
 with Ada.Strings;                  use Ada.Strings;
@@ -37,6 +38,18 @@ with TGen.Types.Record_Types;      use TGen.Types.Record_Types;
 
 package body TGen.Marshalling is
 
+   ----------------------
+   --  Local Variables --
+   ----------------------
+
+   Array_Length_Limit_Env_Var : constant String := "TGEN_ARRAY_LIMIT";
+   --  Name of the environment variable to be used during generation of the
+   --  marshallers to override the default array length limit.
+
+   Array_Length_Limit : Positive := 1000;
+   --  Limit in the number of elements beyond which the marshallers will not
+   --  even try to create an object, and instead raise an Invalid_Error.
+
    -----------------------
    -- Local Subprograms --
    -----------------------
@@ -81,7 +94,8 @@ package body TGen.Marshalling is
       Fst_Name_Tag : in out Tag;
       Lst_Name_Tag : in out Tag;
       Typ_Tag      : in out Tag;
-      Pref_Tag     : in out Tag);
+      Pref_Tag     : in out Tag;
+      Is_Enum_Tag  : in out Tag);
    --  Compute the tags for the bounds of an unconstrained array type:
    --    * Fst_Name_Tag contains the names of the objects corresponding to
    --      the lower bounds: First_1, ...,
@@ -90,6 +104,7 @@ package body TGen.Marshalling is
    --    * Typ_Tag contains the index types: First_Index ..., and
    --    * Pref_Tag contains the prefix associated to the index base types:
    --      Global_Prefix_First_Index_Base...
+   --    * Is_Enum_Tag contains wether each index type is a enumerated type
 
    function Create_Tags_For_Array_Dims (A_Typ : Array_Typ'Class) return Tag;
    --  Compute the string to be associated to array attributes for each
@@ -323,7 +338,8 @@ package body TGen.Marshalling is
       Fst_Name_Tag : in out Tag;
       Lst_Name_Tag : in out Tag;
       Typ_Tag      : in out Tag;
-      Pref_Tag     : in out Tag)
+      Pref_Tag     : in out Tag;
+      Is_Enum_Tag  : in out Tag)
    is
       First_Name_Tmplt : constant String := "First_@_DIM_@";
       Last_Name_Tmplt  : constant String := "Last_@_DIM_@";
@@ -345,6 +361,9 @@ package body TGen.Marshalling is
 
             Typ_Tag := Typ_Tag & Index_Type;
             Pref_Tag := Pref_Tag & Index_Pref;
+            Is_Enum_Tag :=
+              Is_Enum_Tag & (U_Typ.Index_Types (I).Get.Kind
+                               in Bool_Kind | Char_Kind | Enum_Kind);
          end;
       end loop;
    end Create_Tags_For_Array_Bounds;
@@ -701,6 +720,7 @@ package body TGen.Marshalling is
       Last_Name_Tag  : Tag;
       Comp_Typ_Tag   : Tag;
       Comp_Pref_Tag  : Tag;
+      Is_Enum_Tag    : Tag;
       Ada_Dim_Tag    : constant Tag :=
         (if Typ in Array_Typ'Class
          then Create_Tags_For_Array_Dims (Array_Typ'Class (Typ))
@@ -723,7 +743,11 @@ package body TGen.Marshalling is
 
                Create_Tags_For_Array_Bounds
                  (U_Typ,
-                  First_Name_Tag, Last_Name_Tag, Comp_Typ_Tag, Comp_Pref_Tag);
+                  First_Name_Tag,
+                  Last_Name_Tag,
+                  Comp_Typ_Tag,
+                  Comp_Pref_Tag,
+                  Is_Enum_Tag);
             end;
 
          else
@@ -757,7 +781,9 @@ package body TGen.Marshalling is
                  3  => Assoc ("LAST_NAME", Last_Name_Tag),
                  4  => Assoc ("COMP_TYP", Comp_Typ_Tag),
                  5  => Assoc ("COMP_PREFIX", Comp_Pref_Tag),
-                 6  => Assoc ("ADA_DIM", Ada_Dim_Tag)];
+                 6  => Assoc ("ADA_DIM", Ada_Dim_Tag),
+                 7  => Assoc ("IS_ENUM", Is_Enum_Tag),
+                 8  => Assoc ("ARR_LIMIT", Array_Length_Limit)];
 
          begin
             Print_Header (Assocs);
@@ -1108,4 +1134,25 @@ package body TGen.Marshalling is
       Append (Str.all, Ada.Characters.Latin_1.LF);
    end New_Line;
 
+begin
+
+   if Ada.Environment_Variables.Exists (Array_Length_Limit_Env_Var) then
+      declare
+         Env_Val : Positive;
+      begin
+         Env_Val :=
+           Positive'Value
+             (Ada.Environment_Variables.Value (Array_Length_Limit_Env_Var));
+         Array_Length_Limit := Env_Val;
+      exception
+         when Constraint_Error =>
+            Put_Line
+              (File => Standard_Error,
+               Item => "Warning: Could not interpret value of the "
+                       & Array_Length_Limit_Env_Var & "environment variable as"
+                       & " a positive, defaulting to"
+                       & Array_Length_Limit'Image);
+      end;
+   end if;
+
 end TGen.Marshalling;

src/tgen/tgen_rts/tgen-marshalling_lib.ads

@@ -23,15 +23,20 @@
 
 with Ada.Streams;
 with Interfaces; use Interfaces;
+with System;
 
 with TGen.JSON; use TGen.JSON;
 
 package TGen.Marshalling_Lib is
 
    Invalid_Value : exception;
+   --  Exception raised by the marshallers when reading an invalid value from
+   --  a stream.
 
    type Offset_Type is mod 8;
 
+   type Biggest_Int is mod System.Max_Binary_Modulus;
+
    procedure Write_Padding
      (Stream : not null access Ada.Streams.Root_Stream_Type'Class;
       Buffer : in out Unsigned_8;

testsuite/tests/test/151_arr_limit/example_gen.adb

@@ -0,0 +1,56 @@
+with Ada.Directories;             use Ada.Directories;
+with Ada.Streams;
+with Ada.Streams.Stream_IO;       use Ada.Streams.Stream_IO;
+with Ada.Text_IO;                 use Ada.Text_IO;
+with Interfaces;                  use Interfaces;
+with My_File;                     use My_File;
+with My_File.TGen_Support;        use My_File.TGen_Support;
+with TGen.JSON;
+with TGen.TGen_Support;           use TGen.TGen_Support;
+with TGen.Marshalling_Lib;
+
+procedure Example_Gen is
+
+   Arr : My_Arr (1 .. 10, Mon .. Mon) :=
+     (for I in 1 .. 10 => (Mon => 1));
+
+   Arr_2 : My_Arr (1 .. 1, Mon .. Sun) :=
+     (1 => (for Day in Weekday => 1));
+
+   Filename : constant String := "scratchpad.bin";
+   File : Ada.Streams.Stream_IO.File_Type;
+   S : Stream_Access;
+begin
+   Create (File, Out_File, Filename);
+   S := Stream (File);
+   TGen_Marshalling_My_File_My_Arr_Output (S, Arr);
+   Close (File);
+   Open (File, In_File, Filename);
+   S := Stream (File);
+   begin
+      declare
+         Arr_In : My_Arr := TGen_Marshalling_My_File_My_Arr_Input (S);
+      begin
+         Put_Line ("did not raise an exception when reading array");
+      end;
+   exception
+      when TGen.Marshalling_Lib.Invalid_Value => null;
+   end;
+   Close (File);
+   Open (File, Out_File, Filename);
+   S := Stream (File);
+   TGen_Marshalling_My_File_My_Arr_Output (S, Arr_2);
+   Close (File);
+   Open (File, In_File, Filename);
+   S := Stream (File);
+   begin
+      declare
+         Arr_2_In : My_Arr := TGen_Marshalling_My_File_My_Arr_Input (S);
+      begin
+         Put_Line ("did not raise an exception when reading array");
+      end;
+   exception
+      when TGen.Marshalling_Lib.Invalid_Value => null;
+   end;
+   Close (File);
+end;

testsuite/tests/test/151_arr_limit/test.sh

@@ -0,0 +1,11 @@
+#!/bin/bash
+
+LALTOOLS_ROOT=$(dirname $(which gnattest))/..
+TEMPLATES_PATH=$LALTOOLS_ROOT/share/tgen/templates
+mkdir -p test/obj obj
+# Set a very low limit in the array size, writing arrays over this size is not
+# impacted, but we should not be able to read them back.
+export TGEN_ARRAY_LIMIT=3
+tgen_marshalling -P test/test.gpr --templates-dir=$TEMPLATES_PATH -o test/tgen_support test/my_file.ads
+gprbuild -q -P test_gen.gpr
+./obj/example_gen

testsuite/tests/test/151_arr_limit/test.yaml

@@ -0,0 +1,8 @@
+description:
+    Test that reading an array from a blob that has a dimension greater
+    that the limit set through the TGEN_ARRAY_LIMIT environment variable
+    does raise an exception.
+
+driver: shell_script
+control:
+    - [XFAIL, 'x86', 'Marshalling not working for 32bits (UB03-008)']

testsuite/tests/test/151_arr_limit/test/my_file.ads

@@ -0,0 +1,9 @@
+package My_File is
+
+   type Weekday is (Mon, Tue, Wed, Thu, Fri, Sat, Sun);
+
+   type My_Arr is array (Positive range <>, Weekday range <>) of Positive;
+
+   procedure Foo (X : My_Arr) with Import;
+
+end My_File;

testsuite/tests/test/151_arr_limit/test/test.gpr

@@ -0,0 +1,9 @@
+project Test is
+
+   for Object_Dir use "obj";
+
+   package Compiler is
+      for Switches ("ada") use ("-gnat2020");
+   end Compiler;
+
+end Test;

testsuite/tests/test/151_arr_limit/test_gen.gpr

@@ -0,0 +1,19 @@
+with "test/test.gpr";
+with "test/tgen_support/tgen_support.gpr";
+with "tgen_rts.gpr";
+
+project Test_Gen is
+
+   for Main use ("example_gen.adb");
+
+   for Object_Dir use "obj";
+
+   package Builder is
+      for Switches ("ada") use ("-g", "-gnat2022");
+   end Builder;
+
+   package Linker is
+      for Switches ("ada") use ("-g");
+   end Linker;
+
+end Test_Gen;