Merge branch 'mr/pmderodat/expr-func' into 'master'

Fix instrumentation of the "next part" of primitive expression functions

See merge request eng/das/cov/gnatcoverage!724

When the completion of an expression function is not directly in a
package spec declarative part, it is possible to create the augmented
expression function in the same scope.

This fixes recent regressions such as: https://gaia.adacore.com/#/e/90021736

For https://gitlab.adacore-it.com/eng/das/cov/gnatcoverage/-/issues/315 and https://gitlab.adacore-it.com/eng/das/cov/gnatcoverage/-/issues/344

Author: pmderodat

testsuite/tests/instr-cov/expr_func/completion/pak.adb

@@ -0,0 +1,25 @@
+pragma Ada_2012;
+
+package body Pak is
+
+   type BT is tagged record
+      X : Integer;
+   end record;
+
+   function Make (Cond : Boolean) return BT
+   is (BT'(X => (if Cond then 1 else 2)));
+
+   type BTT is new BT with record
+      Y : Integer;
+   end record;
+
+   function Make (Cond : Boolean) return BTT
+   is (BTT'(X => 3, Y => 4));
+
+   function Exercise_BT (Cond : Boolean) return Integer
+   is (BT'(Make (Cond)).X);
+
+   function Exercise_BTT (Cond : Boolean) return Integer
+   is (BTT'(Make (Cond)).Y);
+
+end Pak;

testsuite/tests/instr-cov/expr_func/completion/pak.ads

@@ -6,14 +6,22 @@ package Pak is
 
    function Make (Cond : Boolean) return T;
 
+   function Exercise_BT (Cond : Boolean) return Integer;
+   function Exercise_BTT (Cond : Boolean) return Integer;
+
 private
    type T is tagged record
       X : Integer;
    end record;
-   function Make (Cond : Boolean) return T is (T'(X => (if Cond then 1 else 2)));
+
+   function Make (Cond : Boolean) return T
+   is (T'(X => (if Cond then 1 else 2)));
 
    type TT is new T with record
       Y : Integer;
    end record;
-   overriding function Make (Cond : Boolean) return TT is (TT'(X => 3, Y => 4));
+
+   overriding function Make (Cond : Boolean) return TT
+   is (TT'(X => 3, Y => 4));
+
 end Pak;

testsuite/tests/instr-cov/expr_func/completion/test.py

@@ -6,6 +6,9 @@
 gnatcov used to instrument such expression function, which resulted in
 introducing a new primitive (the wrapper generated for MC/DC instrumentation),
 which was not defined for derived types.
+
+This also checks that such expression functions *are* instrumented when they
+are not in a package spec: primitives can be declared only in package specs.
 """
 
 from SCOV.minicheck import build_run_and_coverage, check_xcov_reports
@@ -32,7 +35,8 @@
     "xcov",
     {
         "main.adb.xcov": {"+": {5, 7}},
-        "pak.ads.xcov": {"+": {5, 10, 11, 12, 15, 16, 17}, "?": {13, 18}},
+        "pak.ads.xcov": {"+": {5, 13, 14, 15, 20, 21, 22}, "?": {18, 25}},
+        "pak.adb.xcov": {"+": {5, 6, 7, 12, 13, 14}, "-": {10, 17, 20, 23}},
     },
 )
 

tools/gnatcov/instrument-ada_unit.adb

@@ -456,6 +456,10 @@ package body Instrument.Ada_Unit is
    function Unwrap (N : Expr) return Expr;
    --  Strip Paren_Expr from N
 
+   function In_Package_Spec (N : Ada_Node'Class) return Boolean;
+   --  Return whether N is a direct child of a package specification's
+   --  declarative part (the public or the private one).
+
    function Inclusive_End_Sloc
      (SL : Source_Location_Range) return Source_Location;
    --  End slocs from Libadalang nodes are exclusive: the correspond to the
@@ -4343,7 +4347,13 @@ package body Instrument.Ada_Unit is
          end if;
 
          if Is_Expr_Function then
-            if Return_Type_Is_Controlling (UIC, Common_Nodes) then
+
+            --  If N does not appear in a package spec, creating the augmented
+            --  expression function for it will not create a new primitive.
+
+            if Return_Type_Is_Controlling (UIC, Common_Nodes)
+               and then In_Package_Spec (N)
+            then
 
                --  For the moment when an expression function is a primitive of
                --  a tagged type T, and that T is the return type of the EF,
@@ -7654,6 +7664,28 @@ package body Instrument.Ada_Unit is
       return Unwrapped_N;
    end Unwrap;
 
+   ---------------------
+   -- In_Package_Spec --
+   ---------------------
+
+   function In_Package_Spec (N : Ada_Node'Class) return Boolean is
+      Decl_Part : Declarative_Part;
+   begin
+      if N.Is_Null
+         or else N.Parent.Is_Null
+         or else N.Parent.Kind /= Ada_Ada_Node_List
+         or else N.Parent.Parent.Is_Null
+         or else N.Parent.Parent.Kind not in Ada_Declarative_Part_Range
+      then
+         return False;
+      end if;
+
+      Decl_Part := N.Parent.Parent.As_Declarative_Part;
+      return
+        not Decl_Part.Parent.Is_Null
+        and then Decl_Part.Parent.Kind = Ada_Package_Decl;
+   end In_Package_Spec;
+
    ------------------------
    -- Inclusive_End_Sloc --
    ------------------------