Instrument expr. functions using declare expressions in Ada 2022

Until this change, all methods used to instrument expression functions
had limitations that made them unsuitable for use in all scenarios,
and some expression functions had no viable instrumentation scheme at all.

Ada 2022 introduces declare expressions, which can be used to declare
local objects inside an expression, which was precisely what was missing
in order to fully support expression functions.

This change adds a new instrumentation strategy for expression functions
in Ada 2022 sources.

Author: leocreuse

doc/gnatcov/src_traces.rst

@@ -374,51 +374,53 @@ Unsupported source constructs
 There are a few language constructs that |gcvins| doesn't support.
 The tool emits a warning when it encounters such cases and the corresponding
 code is not instrumented. Source coverage obligations are still emitted, and
-the unsupported constructs will be reported in a separate 
+the unsupported constructs will be reported in a separate
 ``Undetermined_Coverage`` category, to differentiate them from actual coverage
 violations.
 
 The list of unsupported constructs is as follows:
 
-* Generic expression functions,
 * Generic null procedures,
+* Protected bodies entry guards when the ``Simple_Barriers`` restriction or
+  the ``Pure_Barriers`` one apply.
+
+Additionally, if the Ada language version in use, indicated to the tool by
+either a ``pragma Ada_nnnn`` pragma in the sources or through the ``--ada``
+command line switch, is less or equal to Ada 2012, the following constructs are
+also unsupported:
+
+* Generic expression functions,
 * Recursive expression functions which are primitives of some tagged type,
 * Expression functions which are primitives of their return type, when it is a
   tagged type.
-* Protected bodies entry guards when the ``Simple_Barriers`` restriction or
-  the ``Pure_Barriers`` one apply.
 
 The simplest way to work around the limitation concerning expression functions
 is to turn them into regular functions, by giving them a proper body,
 containing a single return statement with the original expression.
 Otherwise it is possible to exempt those constructs (see :ref:`exemptions`)
 and/or perform a manual coverage analysis for these special cases.
 
-Additionally, the MC/DC instrumentation of decisions with many conditions
-may require more memory than available (during instrumentation and/or at
-run-time) to enumerate the possible paths through the decision. To avoid this,
-|gcv| will not instrument such decisions for MC/DC, emitting a warning in the
-process, and the MC/DC coverage for each decision will be reported as
-``Undetermined_Coverage`` state. Should the default limit not be satisfactory,
-it can be tuned with the option :cmd-option:`--path-count-limit`.
+The MC/DC instrumentation of decisions with many conditions may require more
+memory than available (during instrumentation and/or at run-time) to enumerate
+the possible paths through the decision. To avoid this, |gcv| will not
+instrument such decisions for MC/DC, emitting a warning in the process, and the
+MC/DC coverage for each decision will be reported as ``Undetermined_Coverage``
+state. Should the default limit not be satisfactory, it can be tuned with the
+option :cmd-option:`--path-count-limit`.
 
-Source-coverage obligations limitations
+Other source-traces limitations
 ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
 
 In Ada, variable or type declarations at the package level can yield elaboration
 code. Such code constructs are thus considered to have corresponding coverage
 obligations
 
-In the case where a `pragma Preelaborate` or the `No_Elaboration_Code`
-restriction affects the instrumented unit, variable / type declarations at the
-package level are not considered as coverage obligations. In the former case,
-elaboration code can still be emitted (in rare occurrences), but the pragma is
-too restrictive to instrument such code constructs. In the latter case, no
-elaboration code can be emitted so it is valid not to produce any coverage
-obligation.
-
-Global source traces limitations
-^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+In the case where a `pragma Preelaborate` restriction affects the instrumented
+unit, variable and type declarations at the package level are not considered as
+coverage obligations, although some elaboration code may still be emitted in
+rare instances. Note that declarations within a unit constrained by a
+``No_Elaboration_Code`` pragma don't produce coverage obligation either, which
+is always correct as no executable code can be emitted by the compiler for them.
 
 There are also a few limitations concerning the source trace workflow as a
 whole:

testsuite/tests/instr-cov/expr_func/ada_2022/src/gen.ads

@@ -0,0 +1,21 @@
+pragma Ada_2022;
+
+package Gen is
+
+   generic
+      type Value_Type is private;
+      with function Weight (Self : Value_Type) return Natural;
+   function Weight_Sum (Left, Right : Value_Type) return Natural;
+
+   generic
+      type Value_Type is private;
+      with function Weight (Self : Value_Type) return Natural;
+   function Both_Weights_Null (Left, Right : Value_Type) return Boolean;
+
+   function Weight_Sum (Left, Right : Value_Type) return Natural is
+     (Weight (Left) + Weight (Right)); -- # expr_st
+
+   function Both_Weights_Null (Left, Right : Value_Type) return Boolean is
+     (Weight (Left) = 0 and then Weight (Right) = 0);  -- # expr_dc :o/e:
+
+end Gen;

testsuite/tests/instr-cov/expr_func/ada_2022/src/prim.adb

@@ -0,0 +1,11 @@
+pragma Ada_2022;
+
+package body Prim is
+
+   function Make_Internal (Cond : Boolean) return T is
+      (T'(X => (if Cond then 1 else 2)));  -- # expr_dc :o/d:
+
+   function Make_Internal (Cond : Boolean) return TT is
+     (TT'(X => 3, Y => 4));  -- # expr_st
+
+end Prim;

testsuite/tests/instr-cov/expr_func/ada_2022/src/prim.ads

@@ -0,0 +1,25 @@
+pragma Ada_2022;
+
+package Prim is
+   type T is tagged record
+      X : Integer;
+   end record;
+   function And_Then (X : T; A, B : Boolean) return Boolean is
+      (A and then B);  -- # expr_dc :o/e:
+   function Or_Else (X : T; A, B : Boolean) return Boolean is
+      (A or else B);   -- # expr_dc :o/e:
+
+   function Make_Internal (Cond : Boolean) return T;
+
+   function Make (Cond : Boolean) return T is (Make_Internal (Cond));  -- # expr_st
+
+   type TT is new T with record
+      Y : Integer;
+   end record;
+
+   overriding function Make_Internal (Cond : Boolean) return TT;
+
+   overriding function Make (Cond : Boolean) return TT is
+      (Make_Internal (Cond));  -- # expr_st
+
+end Prim;

testsuite/tests/instr-cov/expr_func/ada_2022/src/rec.ads

@@ -0,0 +1,12 @@
+pragma Ada_2022;
+
+package Rec is
+
+   type T is tagged record
+      X : Positive;
+   end record;
+
+   function Fact (Input : T) return Positive is
+     (if Input.X = 1 then 1 else Input.X * Fact ((X => Input.X - 1))); -- # expr_dc :o/d:
+
+end Rec;

testsuite/tests/instr-cov/expr_func/ada_2022/src/test_all.adb

@@ -0,0 +1,41 @@
+pragma Ada_2012;
+
+with Gen;  use Gen;
+with Prim; use Prim;
+with Rec;  use Rec;
+
+with Support; use Support;
+
+procedure Test_All is
+   function Identity (X : Natural) return Natural is (X);
+   function Nat_Sum is new Gen.Weight_Sum
+     (Value_Type => Natural, Weight => Identity);
+   function Nat_Both_Null is new Gen.Both_Weights_Null
+     (Value_Type => Natural, Weight => Identity);
+   Val    : Prim.T := (X => 0);
+   Res_T  : Prim.T;
+   Res_TT : Prim.TT;
+begin
+   --  Ensure we get full coverage
+   Assert (Nat_Sum (1, 1) = 2);
+   Assert (Nat_Both_Null (0, 0));
+   Assert (not Nat_Both_Null (0, 1));
+   Assert (not Nat_Both_Null (1, 0));
+   Assert (Fact ((X => 3)) = 6);
+   Assert (And_Then (Val, True, True));
+   Assert (not And_Then (Val, True, False));
+   Assert (not And_Then (Val, False, True));
+   Assert (not Or_Else (Val, False, False));
+   Assert (Or_Else (Val, True, False));
+   Assert (Or_Else (Val, False, True));
+   Res_T := Make (True);
+   Assert (Res_T.X = 1);
+   Res_T := Make (False);
+   Assert (Res_T.X = 2);
+   Res_TT := Make (False);
+   Assert (Res_TT.X = 3 and then Res_TT.Y = 4);
+end Test_All;
+
+--# rec.ads prim.ads prim.adb gen.ads
+--
+-- /expr/ l+ ## 0

testsuite/tests/instr-cov/expr_func/ada_2022/src/test_true.adb

@@ -0,0 +1,33 @@
+pragma Ada_2012;
+
+with Gen;  use Gen;
+with Prim; use Prim;
+with Rec;  use Rec;
+
+with Support; use Support;
+
+procedure Test_True is
+   function Identity (X : Natural) return Natural is (X);
+   function Nat_Sum is new Gen.Weight_Sum
+     (Value_Type => Natural, Weight => Identity);
+   function Nat_Both_Null is new Gen.Both_Weights_Null
+     (Value_Type => Natural, Weight => Identity);
+   Val    : Prim.T := (X => 0);
+   Res_T  : Prim.T;
+   Res_TT : Prim.TT;
+begin
+   Assert (Nat_Sum (1, 1) = 2);
+   Assert (Nat_Both_Null (0, 0));
+   Assert (Fact ((X => 1)) = 1);
+   Assert (Or_Else (Val, False, True));
+   Assert (And_Then (Val, True, True));
+   Res_T := Make (True);
+   Assert (Res_T.X = 1);
+   Res_TT := Make (False);
+   Assert (Res_TT.X = 3 and then Res_TT.Y = 4);
+end Test_True;
+
+--# rec.ads prim.ads prim.adb gen.ads
+--
+-- /expr_st/ l+ ## 0
+-- /expr_dc/ l! ## oF-

testsuite/tests/instr-cov/expr_func/ada_2022/test.opt

@@ -0,0 +1,3 @@
+7.1.2 DEAD Ada 2022 not supported on old toolchains
+5.04a1 DEAD Ada 2022 not supported on old toolchains
+bin-traces DEAD Ada 2022 not supported on bin traces

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

@@ -0,0 +1,22 @@
+"""
+Check that limitations concerning expression function instrumentation are lifted
+when Ada 2022, and thus declare expressions are available.
+
+This test reflects the various limitations that are documented in the user
+manual:
+- generic expression functions (gen.ads)
+- expression functions which are primitives of a tagged type, when that type is
+  the return type of the expression function. (prim.ads)
+- Recursive expression functions which are a primitive of some type (rec.ads)
+
+The above constructs used to not be instrumented by gnatcov and resulted in
+warnings and undetermined coverage items in the reports.
+"""
+
+from SCOV.tc import TestCase
+from SCOV.tctl import CAT
+from SUITE.context import thistest
+
+
+TestCase(category=CAT.mcdc).run()
+thistest.result()

tools/gnatcov/gnatcov_bits_specific.adb

@@ -1319,26 +1319,14 @@ begin
             Has_Matcher : Boolean;
             --  Matcher for the source files to ignore
 
-            Language_Version : Any_Language_Version;
-            pragma Unreferenced (Language_Version);
-
          begin
             Create_Matcher (Ignored_Source_Files, Matcher, Has_Matcher);
 
             declare
                V : constant String := Value (Args, Opt_Ada, "2012");
             begin
-               if V in "83" | "1983" then
-                  Language_Version := Ada_83;
-               elsif V in "95" | "1995" then
-                  Language_Version := Ada_95;
-               elsif V in "05" | "2005" then
-                  Language_Version := Ada_2005;
-               elsif V in "12" | "2012" then
-                  Language_Version := Ada_2012;
-               elsif V in "22" | "2022" then
-                  Language_Version := Ada_2022;
-               else
+               if not Set_Language_Version (Global_Language_Version, From => V)
+               then
                   Fatal_Error ("Bad Ada language version: " & V);
                end if;
             end;