From fb234beb7c44cb48e560c936ab5729becce2f53d Mon Sep 17 00:00:00 2001 From: Corentin Machu Date: Mon, 6 Jan 2025 17:02:07 +0100 Subject: [PATCH] TGen: Add subprogram selection feature --- src/test-actions.adb | 89 +++++++++++++++---- src/test-command_lines.ads | 2 + src/test-common.adb | 28 ++++++ src/test-common.ads | 23 +++++ src/test-generation.adb | 31 +++++-- .../test/234-ignore-subprograms/build.gpr | 3 + .../test/234-ignore-subprograms/src/pkg.ads | 6 ++ .../test/234-ignore-subprograms/test.out | 17 ++++ .../tests/test/234-ignore-subprograms/test.sh | 7 ++ .../test/234-ignore-subprograms/test.yaml | 5 ++ 10 files changed, 185 insertions(+), 26 deletions(-) create mode 100644 testsuite/tests/test/234-ignore-subprograms/build.gpr create mode 100644 testsuite/tests/test/234-ignore-subprograms/src/pkg.ads create mode 100644 testsuite/tests/test/234-ignore-subprograms/test.out create mode 100755 testsuite/tests/test/234-ignore-subprograms/test.sh create mode 100644 testsuite/tests/test/234-ignore-subprograms/test.yaml diff --git a/src/test-actions.adb b/src/test-actions.adb index cc0e25c4..e27b5269 100644 --- a/src/test-actions.adb +++ b/src/test-actions.adb @@ -202,6 +202,44 @@ package body Test.Actions is end if; end Report_Multiple_Output; + function Process_Comma_Separated_String (String_List : String) + return Test.Common.Unbounded_String_Vector; + -- Process a string of comma separated values and returns a vectors of + -- the values. An empty String produces and empty vector. + -- It is up to the caller to free the allocated strings. + + function Process_Comma_Separated_String (String_List : String) + return Test.Common.Unbounded_String_Vector + is + Result : Test.Common.Unbounded_String_Vector; + Value_Begin : Positive := 1; + Value_End : Positive := 1; + + begin + if String_List = "" then + return Result; + end if; + + while Value_End < String_List'Length loop + if String_List (Value_End) = ',' then + Result.Append + (Ada.Strings.Unbounded.To_Unbounded_String + (String_List (Value_Begin .. Value_End - 1))); + Value_Begin := Value_End + 1; + end if; + + Value_End := @ + 1; + end loop; + + if Value_End - Value_Begin >= 1 then + Result.Append + (Ada.Strings.Unbounded.To_Unbounded_String + (String_List (Value_Begin .. Value_End))); + end if; + + return Result; + end Process_Comma_Separated_String; + begin GNATCOLL.Traces.Parse_Config_File; Test.Common.Verbose := Arg (Cmd, Verbose); @@ -894,6 +932,18 @@ package body Test.Actions is Test.Common.Generate_Test_Vectors := True; Test.Common.Request_Lib_Support; + if Arg (Cmd, Gen_Test_Subprograms) /= null then + declare + Subp_List : constant Test.Common.Unbounded_String_Vector := + Process_Comma_Separated_String + (Arg (Cmd, Gen_Test_Subprograms).all); + begin + for E of Subp_List loop + Test.Common.Add_Allowed_Subprograms (E.To_String); + end loop; + end; + end if; + if Arg (Cmd, Enum_Strat) then Test.Common.TGen_Strat_Kind := TGen.Libgen.Stateful; end if; @@ -1216,25 +1266,26 @@ package body Test.Actions is Put (" --stubs-dir=dirname - Stub files are put in subdirs of dirname\n"); Put ("\n"); - Put (" --validate-type-extensions - Run all tests from all parents to check LSP\n"); - Put (" --inheritance-check - Run inherited tests for descendants\n"); - Put (" --no-inheritance-check - Do not run inherited tests for descendants\n"); - Put (" --test-case-only - Create tests only when Test_Case is specified\n"); - Put (" --skeleton-default=(pass|fail) - Default behavior of unimplemented tests\n"); - Put (" --passed-tests=(show|hide) - Default output of passed tests\n"); - Put (" --exit-status=(on|off) - Default usage of the exit status\n"); - Put (" --omit-sloc - Don't record subprogram sloc in test package\n"); - Put (" --no-command-line - Don't add command line support to test driver\n"); - Put (" --test-duration - Show timing for each test\n"); - Put (" --test-filtering - Add test filtering option to generated driver\n"); - Put (" --no-test-filtering - Suppress test filtering in generated driver\n"); - Put (" --gen-test-vectors - Generate test inputs for supported subprograms (experimental)\n"); - Put (" --gen-test-num=n - Specify the number of test inputs to be generated (experimental, defaults to 5)\n"); - Put (" --serialized-test-dir=dir - Specify in which directory test inputs should be generated (experimental)\n"); - Put (" --dump-test-inputs - Dump input values of the subprogram under test as blobs during harness execution (experimental)\n"); - Put (" --minimize - Minimize the generated testsuite based on structural coverage analysis (experimental)\n"); - Put (" --minimization-filter=file:line - Only minimize tests for the subprogram declared at file:line (file must be a simple name)\n"); - Put (" --cov-level=level - Use level as the coverage level to guide test minimization (see gnatcov help for available choices)\n"); + Put (" --validate-type-extensions - Run all tests from all parents to check LSP\n"); + Put (" --inheritance-check - Run inherited tests for descendants\n"); + Put (" --no-inheritance-check - Do not run inherited tests for descendants\n"); + Put (" --test-case-only - Create tests only when Test_Case is specified\n"); + Put (" --skeleton-default=(pass|fail) - Default behavior of unimplemented tests\n"); + Put (" --passed-tests=(show|hide) - Default output of passed tests\n"); + Put (" --exit-status=(on|off) - Default usage of the exit status\n"); + Put (" --omit-sloc - Don't record subprogram sloc in test package\n"); + Put (" --no-command-line - Don't add command line support to test driver\n"); + Put (" --test-duration - Show timing for each test\n"); + Put (" --test-filtering - Add test filtering option to generated driver\n"); + Put (" --no-test-filtering - Suppress test filtering in generated driver\n"); + Put (" --gen-test-vectors - Generate test inputs for supported subprograms (experimental)\n"); + Put (" --gen-test-num=n - Specify the number of test inputs to be generated (experimental, defaults to 5)\n"); + Put (" --gen-test-subprograms=file:line - Specify a comma separated list of subprograms declared at file:line to generate test cases for\n"); + Put (" --serialized-test-dir=dir - Specify in which directory test inputs should be generated (experimental)\n"); + Put (" --dump-test-inputs - Dump input values of the subprogram under test as blobs during harness execution (experimental)\n"); + Put (" --minimize - Minimize the generated testsuite based on structural coverage analysis (experimental)\n"); + Put (" --minimization-filter=file:line - Only minimize tests for the subprogram declared at file:line (file must be a simple name)\n"); + Put (" --cov-level=level - Use level as the coverage level to guide test minimization (see gnatcov help for available choices)\n"); Put ("\n"); Put ("Tests execution mode options:\n"); diff --git a/src/test-command_lines.ads b/src/test-command_lines.ads index 02881815..6694a4d9 100644 --- a/src/test-command_lines.ads +++ b/src/test-command_lines.ads @@ -92,6 +92,7 @@ package Test.Command_Lines is Copy_Environment, Reporter, Gen_Test_Num, + Gen_Test_Subprograms, Serialized_Test_Dir, Cov_Level, Minimization_Filter); @@ -113,6 +114,7 @@ package Test.Command_Lines is Copy_Environment => '=', Reporter => '=', Gen_Test_Num => '=', + Gen_Test_Subprograms => '=', Serialized_Test_Dir => '=', Cov_Level => '=', Minimization_Filter => '=']); diff --git a/src/test-common.adb b/src/test-common.adb index 7f14373a..eb2d0999 100755 --- a/src/test-common.adb +++ b/src/test-common.adb @@ -41,6 +41,7 @@ with GNAT.Directory_Operations; use GNAT.Directory_Operations; with GNAT.Traceback.Symbolic; with Utils.Tool_Names; +with Utils.String_Utilities; package body Test.Common is @@ -1392,4 +1393,31 @@ package body Test.Common is => Name.P_Is_Ghost_Code); end if; end Is_Ghost_Code; + + ----------------------------- + -- Add_Allowed_Subprograms -- + ----------------------------- + + procedure Add_Allowed_Subprograms (Subp_Decl : String) is + begin + Allowed_Subprograms.Include (Subp_Decl); + end Add_Allowed_Subprograms; + + --------------------------- + -- Is_Subprogram_Allowed -- + --------------------------- + + function Is_Subprogram_Allowed (Subp : Basic_Decl'Class) return Boolean + is + use Utils.String_Utilities; + + Decl_String : constant String := + Ada.Directories.Simple_Name (Subp.Unit.Get_Filename) + & ":" + & Image (Modular (Subp.Sloc_Range.Start_Line)); + begin + return Allowed_Subprograms.Is_Empty + or else Allowed_Subprograms.Contains (Decl_String); + end Is_Subprogram_Allowed; + end Test.Common; diff --git a/src/test-common.ads b/src/test-common.ads index e81b87a3..5e30476a 100755 --- a/src/test-common.ads +++ b/src/test-common.ads @@ -31,9 +31,11 @@ with Langkit_Support.Text; use Langkit_Support.Text; with Ada.Strings.Unbounded; use Ada.Strings.Unbounded; with Ada.Exceptions; +with Ada.Strings.Fixed; with Ada.Containers.Indefinite_Ordered_Maps; with Ada.Containers.Indefinite_Ordered_Sets; with Ada.Containers.Indefinite_Doubly_Linked_Lists; +with Ada.Containers.Vectors; with GNAT.OS_Lib; with GNATCOLL.VFS; use GNATCOLL.VFS; @@ -61,6 +63,12 @@ package Test.Common is package Ada_Nodes_List is new Ada.Containers.Indefinite_Doubly_Linked_Lists (Ada_Node); + package Unbounded_String_Vectors is new + Ada.Containers.Vectors (Index_Type => Positive, + Element_Type => Unbounded_String); + + subtype Unbounded_String_Vector is Unbounded_String_Vectors.Vector; + function Mangle_Hash_Full (Subp : Ada_Node'Class; Case_Sensitive : Boolean := False; @@ -441,6 +449,18 @@ package Test.Common is -- and language version. This function only appends flags to the existing -- one in `gnattest_common.gpr`. + procedure Add_Allowed_Subprograms (Subp_Decl : String) + with Pre => Ada.Strings.Fixed.Index (Subp_Decl, ":") > 0; + -- Add allowed subprograms to the test case generation. All subprograms + -- not explicitly allowed will be ignored during test case generation. + -- The `Subp_Decl` parameter should have the following format + -- `:`. + + function Is_Subprogram_Allowed (Subp : Basic_Decl'Class) return Boolean; + -- Return if `Subp_Name` test case generation is allowed. If no subprograms + -- have been allowed before (the list of allowed subprograms is empty) all + -- subprograms are considered to be allowed. + Preprocessor_Config : Libadalang.Preprocessing.Preprocessor_Data; -- Preprocessor config for the loaded user project. -- Might be null if the project isn't using preprocessing. The @@ -483,6 +503,9 @@ package Test.Common is Lang_Version : Ada_Version_Type := Ada_2012; -- Language version to be inserted in the pragma in stub helper units. + Allowed_Subprograms : String_Set.Set; + -- Set of allowed subprograms with the format : + private Need_Lib_Support : Lib_Support_Status := Not_Needed; diff --git a/src/test-generation.adb b/src/test-generation.adb index fe76c06c..628aeb9c 100644 --- a/src/test-generation.adb +++ b/src/test-generation.adb @@ -58,6 +58,20 @@ package body Test.Generation is function Traverse_Helper (Node : Ada_Node'Class) return Visit_Status is use TGen.Strings; Diags : String_Vector; + + procedure Report_Failures; + -- Reports processing failures and skipped subprograms to the user. + + --------------------- + -- Report_Failures -- + --------------------- + + procedure Report_Failures is + begin + Report_Err + ("Error while processing " & Node.Image & ":" & ASCII.LF + & Join (Diags) & ASCII.LF); + end Report_Failures; begin -- Do not traverse package bodies @@ -95,6 +109,14 @@ package body Test.Generation is | Ada_Subp_Renaming_Decl then + -- Don't do anything if the subprogram isn't allowed (in case the + -- user is filtering test generation). + + if not Test.Common.Is_Subprogram_Allowed (Node.As_Basic_Decl) then + Report_Std (Node.Image & ": subprogram skipped"); + 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. @@ -121,9 +143,7 @@ package body Test.Generation is (Test.Common.TGen_Libgen_Ctx, Node.As_Basic_Decl, Diags, Is_Top_Level_Generic_Instantiation => True) then - Report_Err - ("Error while processing " & Node.Image & ":" & ASCII.LF - & Join (Diags) & ASCII.LF); + Report_Failures; end if; return Over; end if; @@ -132,10 +152,7 @@ package body Test.Generation is if not Include_Subp (Test.Common.TGen_Libgen_Ctx, Node.As_Basic_Decl, Diags) then - - Report_Err - ("Error while processing " & Node.Image & ":" & ASCII.LF - & Join (Diags) & ASCII.LF); + Report_Failures; end if; return Over; end if; diff --git a/testsuite/tests/test/234-ignore-subprograms/build.gpr b/testsuite/tests/test/234-ignore-subprograms/build.gpr new file mode 100644 index 00000000..2e451e4c --- /dev/null +++ b/testsuite/tests/test/234-ignore-subprograms/build.gpr @@ -0,0 +1,3 @@ +project Build is + for Source_Dirs use ("src"); +end Build; diff --git a/testsuite/tests/test/234-ignore-subprograms/src/pkg.ads b/testsuite/tests/test/234-ignore-subprograms/src/pkg.ads new file mode 100644 index 00000000..e368b35d --- /dev/null +++ b/testsuite/tests/test/234-ignore-subprograms/src/pkg.ads @@ -0,0 +1,6 @@ +package Pkg is + function Inc (A : Integer) return Integer is (A + 1); + function Dec (A : Integer) return Integer is (A - 1); + function Mul (A : Integer; B : Integer) return Integer is (A * B); + function Div (A : Integer; B : Integer) return Integer is (A / B); +end Pkg; diff --git a/testsuite/tests/test/234-ignore-subprograms/test.out b/testsuite/tests/test/234-ignore-subprograms/test.out new file mode 100644 index 00000000..2ab541e1 --- /dev/null +++ b/testsuite/tests/test/234-ignore-subprograms/test.out @@ -0,0 +1,17 @@ +: subprogram skipped +: subprogram skipped +pkg.ads:3:4: info: corresponding test PASSED +pkg.ads:3:4: info: corresponding test PASSED +pkg.ads:3:4: info: corresponding test PASSED +pkg.ads:3:4: info: corresponding test PASSED +pkg.ads:3:4: info: corresponding test PASSED +pkg.ads:2:4: info: corresponding test PASSED +pkg.ads:2:4: info: corresponding test PASSED +pkg.ads:2:4: info: corresponding test PASSED +pkg.ads:2:4: info: corresponding test PASSED +pkg.ads:2:4: info: corresponding test PASSED +pkg.ads:2:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:45) +pkg.ads:3:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:66) +pkg.ads:4:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:87) +pkg.ads:5:4: error: corresponding test FAILED: Test not implemented. (pkg-test_data-tests.adb:108) +14 tests run: 10 passed; 4 failed; 0 crashed. diff --git a/testsuite/tests/test/234-ignore-subprograms/test.sh b/testsuite/tests/test/234-ignore-subprograms/test.sh new file mode 100755 index 00000000..933f3e97 --- /dev/null +++ b/testsuite/tests/test/234-ignore-subprograms/test.sh @@ -0,0 +1,7 @@ +#!/usr/bin/env bash + +gnattest -P build.gpr \ + --gen-test-vectors \ + --gen-test-subprograms=pkg.ads:2,pkg.ads:3 +gprbuild -q -P ./gnattest/harness/test_driver.gpr +./gnattest/harness/test_runner diff --git a/testsuite/tests/test/234-ignore-subprograms/test.yaml b/testsuite/tests/test/234-ignore-subprograms/test.yaml new file mode 100644 index 00000000..a4ca124b --- /dev/null +++ b/testsuite/tests/test/234-ignore-subprograms/test.yaml @@ -0,0 +1,5 @@ +description: | + Check that test case generation for explicit subprograms via + `--gen-test-subprograms`. + +driver: shell_script