From 5ac574006a2f54cd7a44d1c4f7c6db1795081e9c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9o=20Creuse?= Date: Thu, 22 Feb 2024 13:39:24 +0100 Subject: [PATCH] TGen: Enable test generation for subprograms with no parameters If a progam has no parameters, but has global variable inputs, then tests are now generated for those. --- share/tgen/templates/generation_routine.tmplt | 4 ++-- .../json_templates/function_tc_dump.tmplt | 4 ++-- src/test-generation.adb | 19 ++++++++++++++++--- src/test-skeleton.adb | 7 +++++-- src/tgen/tgen-libgen.adb | 11 ++++++++--- .../tgen-marshalling-json_marshallers.adb | 2 +- .../tests/test/146-gen_full_glob/pkg.adb | 16 ++++++++++++++++ .../tests/test/146-gen_full_glob/pkg.ads | 10 ++++++++++ .../tests/test/146-gen_full_glob/prj.gpr | 4 ++++ .../tests/test/146-gen_full_glob/test.out | 8 ++++++++ .../tests/test/146-gen_full_glob/test.sh | 3 +++ .../tests/test/146-gen_full_glob/test.yaml | 7 +++++++ 12 files changed, 82 insertions(+), 13 deletions(-) create mode 100644 testsuite/tests/test/146-gen_full_glob/pkg.adb create mode 100644 testsuite/tests/test/146-gen_full_glob/pkg.ads create mode 100644 testsuite/tests/test/146-gen_full_glob/prj.gpr create mode 100644 testsuite/tests/test/146-gen_full_glob/test.out create mode 100644 testsuite/tests/test/146-gen_full_glob/test.sh create mode 100644 testsuite/tests/test/146-gen_full_glob/test.yaml diff --git a/share/tgen/templates/generation_routine.tmplt b/share/tgen/templates/generation_routine.tmplt index 1b726183..df9f0d1b 100644 --- a/share/tgen/templates/generation_routine.tmplt +++ b/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_@, diff --git a/share/tgen/templates/json_templates/function_tc_dump.tmplt b/share/tgen/templates/json_templates/function_tc_dump.tmplt index ab152790..6029f613 100644 --- a/share/tgen/templates/json_templates/function_tc_dump.tmplt +++ b/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_@; diff --git a/src/test-generation.adb b/src/test-generation.adb index d752eeee..5457cbe0 100644 --- a/src/test-generation.adb +++ b/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 diff --git a/src/test-skeleton.adb b/src/test-skeleton.adb index d3c2bf30..612bf851 100755 --- a/src/test-skeleton.adb +++ b/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; ------------------------ diff --git a/src/tgen/tgen-libgen.adb b/src/tgen/tgen-libgen.adb index 6323dde4..2725fe87 100644 --- a/src/tgen/tgen-libgen.adb +++ b/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. diff --git a/src/tgen/tgen-marshalling-json_marshallers.adb b/src/tgen/tgen-marshalling-json_marshallers.adb index bbacaaad..0f61b898 100644 --- a/src/tgen/tgen-marshalling-json_marshallers.adb +++ b/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)); diff --git a/testsuite/tests/test/146-gen_full_glob/pkg.adb b/testsuite/tests/test/146-gen_full_glob/pkg.adb new file mode 100644 index 00000000..94c8a5fc --- /dev/null +++ b/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; diff --git a/testsuite/tests/test/146-gen_full_glob/pkg.ads b/testsuite/tests/test/146-gen_full_glob/pkg.ads new file mode 100644 index 00000000..08339260 --- /dev/null +++ b/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; diff --git a/testsuite/tests/test/146-gen_full_glob/prj.gpr b/testsuite/tests/test/146-gen_full_glob/prj.gpr new file mode 100644 index 00000000..d80ce6b7 --- /dev/null +++ b/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; diff --git a/testsuite/tests/test/146-gen_full_glob/test.out b/testsuite/tests/test/146-gen_full_glob/test.out new file mode 100644 index 00000000..04640089 --- /dev/null +++ b/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. diff --git a/testsuite/tests/test/146-gen_full_glob/test.sh b/testsuite/tests/test/146-gen_full_glob/test.sh new file mode 100644 index 00000000..04c4c9dd --- /dev/null +++ b/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 diff --git a/testsuite/tests/test/146-gen_full_glob/test.yaml b/testsuite/tests/test/146-gen_full_glob/test.yaml new file mode 100644 index 00000000..2d23d46a --- /dev/null +++ b/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)']