Merge branch 'leo/146_globs' into 'master'

TGen: Enbale test generation for subprograms with no parameters

Closes #146

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

share/tgen/templates/generation_routine.tmplt

@@ -67,9 +67,9 @@
                 @_GLOBAL_INPUT_FN_@ (Values.Get ("global_values").Get ("@_GLOBAL_NAME_@"));
 @@END_TABLE@@
             end if;
-            @_SUBP_NAME_@_Dump_TC
+            @_SUBP_NAME_@_Dump_TC (
 @@TABLE'ALIGN_ON(":")@@
-              @_LPAR()_@@_GLOBAL_PREFIX_@_@_PARAM_NAME_@ => Ada_@_PARAM_NAME_@,
+               @_GLOBAL_PREFIX_@_@_PARAM_NAME_@ => Ada_@_PARAM_NAME_@,
 @@END_TABLE@@
 @@TABLE'ALIGN_ON(":")@@
                @_GLOBAL_PREFIX_@_@_GLOBAL_SLUG_@ => @_GLOBAL_NAME_@,

share/tgen/templates/json_templates/function_tc_dump.tmplt

@@ -17,9 +17,9 @@
 
    --  Test Case JSON dumper for @_PROC_NAME_@
 
-   procedure @_PROC_NAME_@_Dump_TC
+   procedure @_PROC_NAME_@_Dump_TC (
 @@TABLE'ALIGN_ON(":")@@
-     @_LPAR()_@@_GLOBAL_PREFIX_@_@_PARAM_NAME_@ : @_PARAM_TY_@;
+     @_GLOBAL_PREFIX_@_@_PARAM_NAME_@ : @_PARAM_TY_@;
 @@END_TABLE@@
 @@TABLE'ALIGN_ON(":")@@
       @_GLOBAL_PREFIX_@_@_GLOBAL_SLUG_@ : @_GLOBAL_TY_@ := @_GLOBAL_NAME_@;

src/test-generation.adb

@@ -37,10 +37,15 @@ with GNATCOLL.OS.Process;
 
 with Libadalang.Common; use Libadalang.Common;
 
+with Langkit_Support.Text;
+
 with TGen.Libgen; use TGen.Libgen;
 
 package body Test.Generation is
 
+   Global_Aspect_Name : constant Langkit_Support.Text.Unbounded_Text_Type :=
+     Langkit_Support.Text.To_Unbounded_Text ("Global");
+
    function Traverse_Helper (Node : Ada_Node'Class) return Visit_Status;
    --  If node is a subprogram declaration (regular or generic instantiation),
    --  include it in the Libgen context. Otherwise keep traversing the tree.
@@ -60,13 +65,12 @@ package body Test.Generation is
 
       --  Collect all types used as parameters in subprogram declarations.
       --  Skip generic subprogram declarations as we only care about the
-      --  instantiations. Also skip subprograms with zero parameters as we do
-      --  not yet support generation for global variables as inputs.
+      --  instantiations. Also skip subprograms with zero parameters if there
+      --  is no Global aspect attached.
 
       if Node.Kind in Ada_Basic_Decl
          and then Node.As_Basic_Decl.P_Is_Subprogram
          and then not (Node.Kind in Ada_Enum_Literal_Decl)
-         and then Node.As_Basic_Decl.P_Subp_Spec_Or_Null.P_Params'Length > 0
       then
          --  Skip generic subp decls (these will be processed if they are
          --  instantiated).
@@ -76,6 +80,15 @@ package body Test.Generation is
             return Over;
          end if;
 
+         --  Check, if the subprogram has zero parameters. If so, only add it
+         --  to the generation context if it has a global annotation.
+
+         if Node.As_Basic_Decl.P_Subp_Spec_Or_Null.P_Params'Length = 0
+           and then not Node.As_Basic_Decl.P_Has_Aspect (Global_Aspect_Name)
+         then
+            return Over;
+         end if;
+
          if not Include_Subp
            (Test.Common.TGen_Libgen_Ctx, Node.As_Basic_Decl, Diags)
          then

src/test-skeleton.adb

@@ -7007,7 +7007,7 @@ package body Test.Skeleton is
                Pad_Str : constant String (1 .. Initial_Pad) := [others => ' '];
             begin
                Put (F, Pad_Str & Subp_Content.Get ("fully_qualified_name")
-                    & " (");
+                    & (if Length (Param_Values) /= 0 then " (" else ""));
                for Param_Id in Param_Values loop
                   Put
                     (F,
@@ -7019,7 +7019,10 @@ package body Test.Skeleton is
                      Put (F, ", ");
                   end if;
                end loop;
-               Put (F, ");");
+               if Length (Param_Values) /= 0 then
+                  Put (F, ")");
+               end if;
+               Put (F, ";");
             end Pp_Subp_Call;
 
             ------------------------

src/tgen/tgen-libgen.adb

@@ -745,14 +745,19 @@ package body TGen.Libgen is
                Ctx.Strategy_Map);
          end if;
 
-         for Param of Fct_Typ.Component_Types loop
-
-            --  Fill out the support package map
+         --  Fill out the support package map with the parameter types and the
+         --  global types.
 
+         for Param of Fct_Typ.Component_Types loop
             Ctx.Support_Packs_Per_Unit.Reference (Support_Packs).Include
               (Support_Library_Package (Param.Get.Compilation_Unit_Name));
          end loop;
 
+         for Glob of Fct_Typ.Globals loop
+            Ctx.Support_Packs_Per_Unit.Reference (Support_Packs).Include
+              (Support_Library_Package (Glob.Get.Compilation_Unit_Name));
+         end loop;
+
          --  Get the transitive closure of the types on which the parameters'
          --  types depend, that need to be included in the support library.
 

src/tgen/tgen-marshalling-json_marshallers.adb

@@ -303,7 +303,7 @@ package body TGen.Marshalling.JSON_Marshallers is
       Global_Slugs       : Vector_Tag;
       Global_Types_Slugs : Vector_Tag;
    begin
-      if FN_Typ.Component_Types.Is_Empty then
+      if FN_Typ.Component_Types.Is_Empty and then FN_Typ.Globals.Is_Empty then
          return;
       end if;
       Assocs.Insert (Assoc ("GLOBAL_PREFIX", Global_Prefix));

testsuite/tests/test/146-gen_full_glob/pkg.adb

@@ -0,0 +1,16 @@
+package body Pkg is
+
+   function And_Then return Boolean is
+   begin
+      if Glob_1 then
+         if Glob_2 then
+            return True;
+         else
+            return False;
+         end if;
+      else
+         return False;
+      end if;
+   end And_Then;
+
+end Pkg;

testsuite/tests/test/146-gen_full_glob/pkg.ads

@@ -0,0 +1,10 @@
+package Pkg is
+
+   Glob_1 : Boolean := False;
+
+   Glob_2 : Boolean := False;
+
+   function And_Then return Boolean with
+     Global => (Glob_1, Glob_2);
+
+end Pkg;

testsuite/tests/test/146-gen_full_glob/prj.gpr

@@ -0,0 +1,4 @@
+project Prj is
+    for Object_Dir use "obj";
+    for Source_Dirs use (".");
+end Prj;

testsuite/tests/test/146-gen_full_glob/test.out

@@ -0,0 +1,8 @@
+Units remaining: 2     Units remaining: 1     
+pkg.ads:7:4: info: corresponding test PASSED
+pkg.ads:7:4: info: corresponding test PASSED
+pkg.ads:7:4: info: corresponding test PASSED
+pkg.ads:7:4: info: corresponding test PASSED
+pkg.ads:7:4: info: corresponding test PASSED
+pkg.ads:7:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:45)
+6 tests run: 5 passed; 1 failed; 0 crashed.

testsuite/tests/test/146-gen_full_glob/test.sh

@@ -0,0 +1,3 @@
+gnattest -P prj.gpr --gen-test-vectors
+gprbuild -P obj/gnattest/harness/test_driver.gpr -q
+./obj/gnattest/harness/test_runner

testsuite/tests/test/146-gen_full_glob/test.yaml

@@ -0,0 +1,7 @@
+description:
+    Test support of global variables in TGen, for subprograms with no
+    parameters.
+
+driver: shell_script
+control:
+    - [XFAIL, 'x86', 'Marshalling not working for 32bits (UB03-008)']