Merge branch 'peron/270-cs0040481-add-option-to-include-all-stubbed-units-in-test-haress-project' into 'master'

Resolve "[CS0040481] Add option to include all stubbed units in test haress project"

Closes #270

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

Author: RenjiSann

src/test-actions.adb

@@ -623,6 +623,7 @@ package body Test.Actions is
 
       begin
          Common.Stub_Mode_ON := Arg (Cmd, Stub);
+         Common.Recursive_Stubbing_ON := Arg (Cmd, Recursive_Stub);
 
          for File of File_Names (Cmd) loop
             if not Contains (Ignored, Simple_Name (File.all)) then
@@ -1428,6 +1429,8 @@ package body Test.Actions is
         (" --harness-only          - Treat argument sources as tests to add to the suite\n");
       Put
         (" --stub                  - Generate testing framework that uses stubs\n");
+      Put
+        (" --recursive-stub        - Recursively stub dependencies of stubbed units\n");
       Put ("\n");
 
       Put

src/test-command_lines.ads

@@ -39,6 +39,7 @@ package Test.Command_Lines is
       Recursive,
       Harness_Only,
       Stub,
+      Recursive_Stub,
       Validate_Type_Extensions,
       Inheritance_Check,
       Test_Case_Only,

src/test-common.ads

@@ -320,6 +320,8 @@ package Test.Common is
 
    Stub_Mode_ON : Boolean := False;
 
+   Recursive_Stubbing_ON : Boolean := False;
+
    Transition : Boolean := False;
 
    Omit_Sloc : Boolean := False;

src/test-skeleton.adb

@@ -8346,16 +8346,14 @@ package body Test.Skeleton is
    procedure Get_Units_To_Stub
      (The_Unit : Compilation_Unit; Data : in out Data_Holder)
    is
-      Body_N    : Body_Node;
-      Body_Unit : Compilation_Unit;
-
-      Parent : Ada_Node;
-
       Already_Stubbing : String_Set.Set := String_Set.Empty_Set;
       --  It is generally easier to store units to stub in a list, however
       --  to avoid duplications we use this local set since it is easier
       --  and faster to check membership in a set.
 
+      procedure Do_Get_Stub_Units (The_Unit : Compilation_Unit);
+      --  Recursive implementation helper.
+
       function Good_To_Stub (Check_Unit : Analysis_Unit) return Boolean;
       --  Checks that given unit is suitable for stubbing
 
@@ -8364,7 +8362,7 @@ package body Test.Skeleton is
       --  units to stub.
 
       procedure Iterate_Separates (The_Unit : Compilation_Unit);
-      --  Looks for inuts withed in separate bodies
+      --  Looks for inputs withed in separate bodies
 
       -----------------------
       -- Add_Units_To_Stub --
@@ -8401,6 +8399,15 @@ package body Test.Skeleton is
                               Data.Units_To_Stub.Append
                                 (Withed_Spec.As_Ada_Node);
                               Trace (Me, Withed_Spec_Image);
+
+                              --  Recursively stub
+
+                              if Recursive_Stubbing_ON then
+                                 Trace (Me, "Recursively stub");
+                                 Do_Get_Stub_Units
+                                   (Withed_Spec.Unit.Root.As_Compilation_Unit);
+                              end if;
+
                            end if;
                         end;
 
@@ -8511,55 +8518,73 @@ package body Test.Skeleton is
          return True;
       end Good_To_Stub;
 
-   begin
-      Trace
-        (Me, "units to stub for " & Base_Name (The_Unit.Unit.Get_Filename));
-      Increase_Indent (Me);
-
-      --  Gathering with clauses from spec
-      Add_Units_To_Stub (The_Unit);
-
-      Body_N :=
-        The_Unit
-          .F_Body
-          .As_Library_Item
-          .F_Item
-          .As_Basic_Decl
-          .P_Body_Part_For_Decl;
-
-      --  Gathering with clauses from body
-      if Body_N /= No_Body_Node
-        and then Body_N.Unit.Root.Kind = Ada_Compilation_Unit
-      then
-         Body_Unit := Body_N.Unit.Root.As_Compilation_Unit;
-         Add_Units_To_Stub (Body_Unit);
-         Iterate_Separates (Body_Unit);
-      end if;
+      -----------------------
+      -- Do_Get_Stub_Units --
+      -----------------------
 
-      --  Gathering parent packages
-      Parent :=
-        The_Unit.F_Body.As_Library_Item.F_Item.As_Ada_Node.P_Semantic_Parent;
-      while not Parent.Is_Null and then Parent.Unit /= Parent.P_Standard_Unit
-      loop
-         if Parent.Kind = Ada_Package_Decl then
-            declare
-               Parent_File : constant String := Parent.Unit.Get_Filename;
-            begin
-               if Good_To_Stub (Parent.Unit)
-                 and then not Already_Stubbing.Contains (Parent_File)
-               then
-                  Already_Stubbing.Include (Parent_File);
-                  Data.Units_To_Stub.Append (Parent);
-                  Trace (Me, Parent_File);
-               end if;
-            end;
+      procedure Do_Get_Stub_Units (The_Unit : Compilation_Unit) is
+         Body_N    : Body_Node;
+         Body_Unit : Compilation_Unit;
+
+         Parent : Ada_Node;
+      begin
+         Trace
+           (Me, "units to stub for " & Base_Name (The_Unit.Unit.Get_Filename));
+         Increase_Indent (Me);
+
+         --  Gathering with clauses from spec
+         Add_Units_To_Stub (The_Unit);
+
+         Body_N :=
+           The_Unit
+             .F_Body
+             .As_Library_Item
+             .F_Item
+             .As_Basic_Decl
+             .P_Body_Part_For_Decl;
+
+         --  Gathering with clauses from body
+         if Body_N /= No_Body_Node
+           and then Body_N.Unit.Root.Kind = Ada_Compilation_Unit
+         then
+            Body_Unit := Body_N.Unit.Root.As_Compilation_Unit;
+            Add_Units_To_Stub (Body_Unit);
+            Iterate_Separates (Body_Unit);
          end if;
 
-         Parent := Parent.P_Semantic_Parent;
-      end loop;
+         --  Gathering parent packages
+         Parent :=
+           The_Unit
+             .F_Body
+             .As_Library_Item
+             .F_Item
+             .As_Ada_Node
+             .P_Semantic_Parent;
+         while not Parent.Is_Null
+           and then Parent.Unit /= Parent.P_Standard_Unit
+         loop
+            if Parent.Kind = Ada_Package_Decl then
+               declare
+                  Parent_File : constant String := Parent.Unit.Get_Filename;
+               begin
+                  if Good_To_Stub (Parent.Unit)
+                    and then not Already_Stubbing.Contains (Parent_File)
+                  then
+                     Already_Stubbing.Include (Parent_File);
+                     Data.Units_To_Stub.Append (Parent);
+                     Trace (Me, Parent_File);
+                  end if;
+               end;
+            end if;
+
+            Parent := Parent.P_Semantic_Parent;
+         end loop;
 
-      Decrease_Indent (Me);
-      Already_Stubbing.Clear;
+         Decrease_Indent (Me);
+         Already_Stubbing.Clear;
+      end Do_Get_Stub_Units;
+   begin
+      Do_Get_Stub_Units (The_Unit);
    end Get_Units_To_Stub;
 
    ----------------------

testsuite/tests/test/270-recursive-stubbing/test.out

@@ -0,0 +1 @@
+success

testsuite/tests/test/270-recursive-stubbing/test.sh

@@ -0,0 +1,46 @@
+#!/bin/bash
+
+_exit() {
+    printf $*
+    exit 1
+}
+
+cd test/
+
+# First instrumentation without --recursive stub, there should only be `pkg_b`
+# unit files in the stub folder.
+gnattest -P proj.gpr --stub pkg_a.ads
+
+find obj/gnattest_stub/stubs/Proj/ -name '*pkg_b*' | grep -q .
+[ $? = 0 ] || _exit "Missing expected stub files related to \`pkg_b\`."
+
+find obj/gnattest_stub/stubs/Proj/ -name '*pkg_c*' | grep -q .
+[ $? = 0 ] && _exit "Found unexpected stub files related to \`pkg_c\`."
+
+# Compile the project and see if running it causes a divide by zero error,
+# which is the expected behavior in case Pkg_B is elaborated using the original
+# Pkg_C unit.
+OUT="$(gprbuild -P obj/gnattest_stub/harness/Pkg_A.Test_Data.Tests/test_driver.gpr 2>&1 || true)"
+[ $? = 0 ] || _exit "Unable to compile the project:\n%s" "$OUT"
+
+OUT=$(./obj/gnattest_stub/harness/Pkg_A.Test_Data.Tests/pkg_a-test_data-tests-suite-test_runner 2>&1)
+echo "$OUT" | grep -q -E 'CONSTRAINT_ERROR :.* divide by zero'
+[ $? = 0 ] || _exit "Expected divide by zero error, Got\n$OUT"
+
+# Second instrumentation with --recursive-stub, there should be `pkg_[bc]`
+# unit files in the stub folder.
+gnattest -P proj.gpr --stub --recursive-stub pkg_a.ads
+
+find obj/gnattest_stub/stubs/Proj/ -name '*pkg_c*' | grep -q .
+[ $? = 0 ] || _exit "Missing expected stub files related to \`pkg_c\`."
+
+# Compile the project. Now, if the recursive stubbing works correctly, the
+# program should fail for another reason than divide by zero.
+OUT="$(gprbuild -P obj/gnattest_stub/harness/Pkg_A.Test_Data.Tests/test_driver.gpr 2>&1 || true)"
+[ $? = 0 ] || _exit "Unable to compile the project:\n%s" "$OUT"
+
+OUT=$(./obj/gnattest_stub/harness/Pkg_A.Test_Data.Tests/pkg_a-test_data-tests-suite-test_runner 2>&1)
+echo "$OUT" | grep -q -E 'CONSTRAINT_ERROR :.* divide by zero'
+[ $? = 0 ] && _exit "Unexpected divide by zero error, Got\n$OUT"
+
+printf "success"

testsuite/tests/test/270-recursive-stubbing/test.yaml

@@ -0,0 +1,4 @@
+description: Test that asserts that --stub --recursive-stub option will
+    indeed generate stubs for the withed units of stubbed units.
+
+driver: shell_script

testsuite/tests/test/270-recursive-stubbing/test/proj.gpr

@@ -0,0 +1,6 @@
+project Proj is
+    for Source_Dirs use ("src");
+    for Object_Dir use "obj";
+
+    for Main use ("main.adb");
+end Proj;

testsuite/tests/test/270-recursive-stubbing/test/src/main.adb

@@ -0,0 +1,9 @@
+pragma Ada_2012;
+with Ada.Text_IO; use Ada.Text_IO;
+with Pkg_A; use Pkg_A;
+
+procedure Main is
+begin
+    Put_Line ("Hello WOLD");
+    Print_Magic_Number;
+end Main;

testsuite/tests/test/270-recursive-stubbing/test/src/pkg_a.ads

@@ -0,0 +1,5 @@
+with Pkg_B;
+
+package Pkg_A is
+   procedure Print_Magic_Number renames Pkg_B.Print_Magic_Number;
+end Pkg_A;