Merge branch 'topic/machu/234-filter-subprograms' into 'master'

TGen: Add subprogram selection feature

Closes #234

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

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");

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      => '=']);

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;

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
+   --  `<subp_decl_filename>:<line_number>`.
+
+   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 <filename>:<line number>
+
 private
 
    Need_Lib_Support : Lib_Support_Status := Not_Needed;

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;

testsuite/tests/test/234-ignore-subprograms/build.gpr

@@ -0,0 +1,3 @@
+project Build is
+   for Source_Dirs use ("src");
+end Build;

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;

testsuite/tests/test/234-ignore-subprograms/test.out

@@ -0,0 +1,17 @@
+<ExprFunction ["Mul"] pkg.ads:4:4-4:70>: subprogram skipped
+<ExprFunction ["Div"] pkg.ads:5:4-5:70>: 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.

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

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