Merge branch 'topic/machu/274-gen-test-subprograms-accept-filename' into 'master'

Allow file paths with the `--gen-test-subprograms` option

Closes #274

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

Author: Volham22

src/test-actions.adb

@@ -46,6 +46,7 @@ use Utils;
 use Utils.Command_Lines.Common;
 pragma Unreferenced (Utils.Command_Lines.Common); -- ????
 with Utils.Formatted_Output;
+with Utils.String_Utilities;
 
 with Utils_Debug; use Utils_Debug;
 
@@ -239,7 +240,6 @@ package body Test.Actions is
          return Result;
       end Process_Comma_Separated_String;
 
-      use Ada.Strings.Fixed;
    begin
       GNATCOLL.Traces.Parse_Config_File;
       Test.Common.Verbose := Arg (Cmd, Verbose);
@@ -253,33 +253,22 @@ package body Test.Actions is
          return;
       end if;
 
-      declare
-         Subp_Hash       : constant String_Access := Arg (Cmd, Dump_Subp_Hash);
-         Separator_Index : constant Natural :=
-           (if Subp_Hash /= null then Index (Subp_Hash.all, ":", 1) else 0);
-      begin
-         if Subp_Hash /= null then
-            if Separator_Index = 0 then
-               Cmd_Error_No_Help
-                 ("Unexpected format for --dump-subp-hash, expected <filename>"
-                  & ":<line>");
-            end if;
-            Test.Common.Subp_File_Name :=
-              new String'(Subp_Hash.all (1 .. Separator_Index - 1));
-            begin
-               Test.Common.Subp_Line_Nbr :=
-                 Natural'Value
-                   ((Subp_Hash.all (Separator_Index + 1 .. Subp_Hash'Length)));
-            exception
-               when others =>
-                  Cmd_Error_No_Help ("<line> must be a Natural.");
-            end;
+      if Arg (Cmd, Dump_Subp_Hash) /= null then
+         declare
+            Subp_File_Name : constant String :=
+              Test.Common.Parse_File_And_Number
+                ("--dump-subp-hash",
+                 Arg (Cmd, Dump_Subp_Hash).all,
+                 Test.Common.Subp_Line_Nbr);
+         begin
+            Test.Common.Subp_File_Name := new String'(Subp_File_Name);
             Utils.Command_Lines.Append_File_Name
               (Cmd, Test.Common.Subp_File_Name.all);
             Test.Common.Quiet := True;
-            return;
-         end if;
-      end;
+         end;
+
+         return;
+      end if;
 
       Test.Common.Instrument := Arg (Cmd, Dump_Test_Inputs);
 
@@ -1051,7 +1040,20 @@ package body Test.Actions is
                    (Arg (Cmd, Gen_Test_Subprograms).all);
             begin
                for E of Subp_List loop
-                  Test.Common.Add_Allowed_Subprograms (E.To_String);
+                  declare
+                     Line_Number : Natural;
+                     File_Path   : constant String :=
+                       Test.Common.Parse_File_And_Number
+                         ("--gen-test-subprograms",
+                          E.To_String,
+                          Line_Number,
+                          Extract_File_Name => True);
+                  begin
+                     Test.Common.Add_Allowed_Subprograms
+                       (File_Path
+                        & ":"
+                        & Utils.String_Utilities.Image (Line_Number));
+                  end;
                end loop;
             end;
          end if;

src/test-common.adb

@@ -1445,4 +1445,44 @@ package body Test.Common is
         or else Allowed_Subprograms.Contains (Decl_String);
    end Is_Subprogram_Allowed;
 
+   ---------------------------
+   -- Parse_File_And_Number --
+   ---------------------------
+
+   function Parse_File_And_Number
+     (Arg_Name, Arg_Val : String;
+      Line_Number       : out Natural;
+      Extract_File_Name : Boolean := False) return String
+   is
+      Split_Index : constant Natural := Ada.Strings.Fixed.Index (Arg_Val, ":");
+   begin
+      if Split_Index = 0 then
+         Cmd_Error_No_Help
+           ("Unexpected format for "
+            & Arg_Name
+            & ", expected <filename>"
+            & ":<line>");
+      end if;
+
+      declare
+         User_File_Path   : constant String :=
+           Arg_Val (Arg_Val'First .. Split_Index - 1);
+         User_Line_Number : constant String :=
+           Arg_Val (Split_Index + 1 .. Arg_Val'Last);
+      begin
+         begin
+            Line_Number := Natural'Value (User_Line_Number);
+         exception
+            when Constraint_Error =>
+               Cmd_Error_No_Help
+                 (User_Line_Number & " must be a positive number");
+         end;
+
+         return
+           (if Extract_File_Name
+            then Ada.Directories.Simple_Name (User_File_Path)
+            else User_File_Path);
+      end;
+   end Parse_File_And_Number;
+
 end Test.Common;

src/test-common.ads

@@ -298,7 +298,7 @@ package Test.Common is
    --  The root directory to place the test file hierarchy in case of
    --  --separate-root option.
 
-   Subp_File_Name : String_Access;
+   Subp_File_Name : String_Access := null;
    --  Name of the file from which we want to extract the hash in case of the
    --  --dump-subp-hash option
 
@@ -468,12 +468,26 @@ package Test.Common is
    --  not explicitly allowed will be ignored during test case generation.
    --  The `Subp_Decl` parameter should have the following format
    --  `<subp_decl_filename>:<line_number>`.
+   --  Note: `subp_decl_filename` can be an absolute or relative path to the
+   --  source file. The filename will be extracted from the given path.
 
    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.
 
+   function Parse_File_And_Number
+     (Arg_Name, Arg_Val : String;
+      Line_Number       : out Natural;
+      Extract_File_Name : Boolean := False) return String;
+   --  Parse a file name and a line number separated by a single colon for
+   --  an argument `Arg_Name` and its associated value `Arg_Val`.
+   --  The parsed file name will be returned. If `Extract_File_Name` is set,
+   --  only the file name is returned.
+   --
+   --  CAUTION: **This function will call `Cmd_Error_No_Help`** if the input is
+   --  ill formated. This function is intended to handle user inputs.
+
    Preprocessor_Config : Libadalang.Preprocessing.Preprocessor_Data;
    --  Preprocessor config for the loaded user project.
    --  Might be null if the project isn't using preprocessing. The

testsuite/tests/test/274-gen_test_subprograms_bad_arguments/src/pkg.ads

@@ -0,0 +1,3 @@
+package Pkg is
+   function Identity (X : Integer) return Integer is (X);
+end Pkg;

testsuite/tests/test/274-gen_test_subprograms_bad_arguments/test.out

@@ -0,0 +1,3 @@
+gnattest: Unexpected format for --gen-test-subprograms, expected <filename>:<line>
+gnattest: abc must be a positive number
+>>>program returned status code 1

testsuite/tests/test/274-gen_test_subprograms_bad_arguments/test.sh

@@ -0,0 +1,10 @@
+#!/usr/bin/env bash
+
+gnattest \
+    -P user_project.gpr \
+    --gen-test-vectors \
+    --gen-test-subprograms=./src/foo.ads
+gnattest \
+    -P user_project.gpr \
+    --gen-test-vectors \
+    --gen-test-subprograms=./src/foo.ads:abc

testsuite/tests/test/274-gen_test_subprograms_bad_arguments/test.yaml

@@ -0,0 +1,5 @@
+description: |
+  Check that gnattest rejects erroneous inputs that are not formatted following
+  this `<filename>:<number>` pattern.
+
+driver: shell_script

testsuite/tests/test/274-gen_test_subprograms_bad_arguments/user_project.gpr

@@ -0,0 +1,9 @@
+project User_Project is
+   for Source_Dirs use ("src");
+   for Create_Missing_Dirs use "True";
+   for Object_Dir use "obj";
+   package Compiler is
+      for Switches ("Ada") use
+        ("-gnatwI", "-g", "-gnat2022", "-gnatf", "-gnatwa");
+   end Compiler;
+end User_Project;

testsuite/tests/test/274-gen_test_subprograms_filepaths/prj.gpr

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

testsuite/tests/test/274-gen_test_subprograms_filepaths/src/foo.ads

@@ -0,0 +1,5 @@
+package Foo is
+   function Plus_Two (X : Integer) return Integer is (X + 2);
+   function Double (X : Integer) return Integer is (X * 2);
+   --  Ignored
+end Foo;