Skip to content

Commit 13175e2

Browse files
pmderodatJugst3r
pmderodat
authored and
Jugst3r
committed
Instrument Ada: add support for preprocessing
Extract preprocessor configuration data from project files and pass it to Libadalang, so that instrumentation works on preprocessed code. Naturally, this allows gnatcov to compute the code coverage only for code that is left "enabled" by preprocessing directives: disabled code (i.e. equivalent to `#if false`) is ignored and thus creates no coverage obligation. Note that consolidation will not help including code from all "preprocessing branches" in coverage reports, as gnatcov requires (and checks) that coverage obligations are the same for two units to consolidate. Similarly, the coverage obligations for code that comes from symbol expansion (`$Foo` expanded into `Bar` with `-Dfoo=Bar`) designates expanded code. Even though line numbers are preserved during preprocessing, column numbers may be different between original code and preprocessed code and thus coverage reports. This is a limitation from Libadalang's preprocessing facilities, so not something we could fix at the gnatcov level, but this limitation is not considered problematic at this point for the known use cases of coverage on code with preprocessing directives. (cherry picked from commit 8a69f32)
1 parent 6ee0c8b commit 13175e2

36 files changed

+1000
-26
lines changed

‎testsuite/tests/138-ada-preprocessing/errors/bad_syntax.txt‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
:=

‎testsuite/tests/138-ada-preprocessing/errors/eval_error.txt‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
* -c

‎testsuite/tests/138-ada-preprocessing/errors/main.adb‎

Lines changed: 6 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,6 @@
1+
with Pkg;
2+
3+
procedure Main is
4+
begin
5+
null;
6+
end Main;

‎testsuite/tests/138-ada-preprocessing/errors/pkg.ads‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
package Pkg is
2+
# if Log then
3+
procedure Log;
4+
# end if ;
5+
end Pkg;

‎testsuite/tests/138-ada-preprocessing/errors/test.py‎

Lines changed: 67 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,67 @@
1+
"""
2+
Check various error cases related to the use of preprocessing in Ada.
3+
"""
4+
5+
import os
6+
import os.path
7+
8+
from SCOV.instr import xcov_instrument
9+
from SUITE.context import thistest
10+
from SUITE.cutils import Wdir, contents_of
11+
from SUITE.tutils import gprfor
12+
from SUITE.gprutils import GPRswitches
13+
14+
15+
tmp = Wdir("tmp_")
16+
17+
# Avoid "creating output path" info messages
18+
os.mkdir("obj")
19+
20+
for basename, expected_msg in [
21+
(
22+
"no_such_file",
23+
".*gnatcov.*: error while loading preprocessor data from project"
24+
"\n.*gnatcov.*: no such file: .*no_such_file\\.txt",
25+
),
26+
(
27+
"bad_syntax",
28+
".*gnatcov.*: error while loading preprocessor data from project"
29+
"\n.*gnatcov.*: .*bad_syntax\\.txt:1:1: Ada source filename expected",
30+
),
31+
(
32+
"eval_error",
33+
".*gnatcov.*: instrumentation failed for .*pkg\\.ads"
34+
"\n.*gnatcov.*: please make sure the original project can be"
35+
" compiled"
36+
'\n.*gnatcov.*: pkg\\.ads:2:6: unknown symbol "Log"',
37+
),
38+
]:
39+
thistest.log(f"== {basename} ==")
40+
log_filename = f"{basename}-out.txt"
41+
p = xcov_instrument(
42+
gprsw=GPRswitches(
43+
root_project=gprfor(
44+
prjid=basename,
45+
mains=["main.adb"],
46+
srcdirs=[".."],
47+
compiler_extra=(
48+
'for Default_Switches ("Ada")'
49+
' use ("-gnatep="'
50+
" & Project'Project_Dir"
51+
f' & "/../{basename}.txt");'
52+
),
53+
)
54+
),
55+
covlevel="stmt",
56+
register_failure=False,
57+
out=log_filename,
58+
)
59+
thistest.fail_if(p.status == 0, "'gnatcov instrument' is supposed to fail")
60+
output = contents_of(log_filename)
61+
thistest.fail_if_no_match(
62+
"'gnatcov instrument' output",
63+
expected_msg,
64+
contents_of(log_filename).strip(),
65+
)
66+
67+
thistest.result()

‎testsuite/tests/138-ada-preprocessing/example/prep.txt‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1 @@
1+
* -Dlog=false -c

‎testsuite/tests/138-ada-preprocessing/example/test.py‎

Lines changed: 83 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,83 @@
1+
"""
2+
Check that the instrumentation of Ada sources with preprocessing enabled works
3+
as expected on an example project.
4+
"""
5+
6+
import os
7+
import os.path
8+
9+
from SCOV.minicheck import build_run_and_coverage, check_xcov_reports
10+
from SUITE.context import thistest
11+
from SUITE.cutils import Wdir
12+
from SUITE.tutils import gprfor
13+
from SUITE.gprutils import GPRswitches
14+
15+
16+
tmp = Wdir("tmp_")
17+
18+
# Avoid "creating output path" info messages
19+
os.mkdir("obj")
20+
21+
# Test the working case. The "log" preprocessing symbol is set to "false" in
22+
# "prep.txt", so all logging lines are supposed to be disabled and thus not
23+
# create coverage obligations. Yet the line numbers for the code remaining are
24+
# supposed to be preserved.
25+
thistest.log("== Up to the coverage report ==")
26+
build_run_and_coverage(
27+
gprsw=GPRswitches(
28+
root_project=gprfor(
29+
mains=["test_eval.adb"],
30+
srcdirs=[".."],
31+
compiler_extra=(
32+
'for Default_Switches ("Ada")'
33+
' use ("-gnatep=" & Project\'Project_Dir & "/../prep.txt");'
34+
),
35+
)
36+
),
37+
covlevel="stmt+decision",
38+
mains=["test_eval"],
39+
extra_coverage_args=["-axcov", "--output-dir=xcov"],
40+
trace_mode="src",
41+
)
42+
check_xcov_reports(
43+
"*.xcov",
44+
{
45+
"test_eval.adb.xcov": {"+": {4}, "!": {12}, "-": {13}},
46+
"vm.ads.xcov": {"+": {3, 4, 6, 7, 16, 17}},
47+
"vm.adb.xcov": {
48+
"+": {
49+
# Eval header
50+
13,
51+
52+
# Pop
53+
27, 31,
54+
55+
# Push
56+
43, 44,
57+
58+
# Eval loop
59+
61, 62, 70, 72, 87, 89, 90, 96,
60+
61+
# Eval wrapper
62+
117, 118, 121, 122, 123, 125, 126, 127,
63+
},
64+
"!": {
65+
# Branch condition evaluation
66+
78
67+
},
68+
"-": {
69+
# Jump
70+
75,
71+
72+
# Branch jump
73+
79,
74+
75+
# Push_Lit, Add
76+
83, 94,
77+
},
78+
},
79+
},
80+
cwd="xcov",
81+
)
82+
83+
thistest.result()

‎testsuite/tests/138-ada-preprocessing/example/test_eval.adb‎

Lines changed: 15 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,15 @@
1+
with VM; use VM;
2+
3+
procedure Test_Eval is
4+
Program : constant Program_Type :=
5+
(1 => (Kind => Clone),
6+
2 => (Kind => Branch, Jump_Dest => 4),
7+
3 => (Kind => Halt),
8+
4 => (Kind => Push_Lit, Push_Value => -1),
9+
5 => (Kind => Add),
10+
6 => (Kind => Jump, Jump_Dest => 1));
11+
begin
12+
if Eval (Program, 5, (1 => 0)) /= 0 then
13+
raise Program_Error;
14+
end if;
15+
end Test_Eval;

‎testsuite/tests/138-ada-preprocessing/example/vm.adb‎

Lines changed: 130 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,130 @@
1+
#if Log then
2+
with Ada.Text_IO; use Ada.Text_IO;
3+
#end if;
4+
5+
package body VM is
6+
7+
procedure Eval
8+
(Program : Program_Type;
9+
PC : in out PC_Type;
10+
Stack : in out Stack_type;
11+
SP : in out SP_Type)
12+
is
13+
Continue : Boolean := True;
14+
15+
function Pop return Integer;
16+
procedure Push (Value : Integer);
17+
18+
---------
19+
-- Pop --
20+
---------
21+
22+
function Pop return Integer is
23+
begin
24+
#if Log then
25+
Put_Line ("Popping the stack");
26+
#end if;
27+
SP := SP - 1;
28+
#if Log then
29+
Put_Line ("SP:" & SP_Type'Image (SP));
30+
#end if;
31+
return Stack (SP);
32+
end Pop;
33+
34+
----------
35+
-- Push --
36+
----------
37+
38+
procedure Push (Value : Integer) is
39+
begin
40+
#if Log then
41+
Put_Line ("Pushing the stack");
42+
#end if;
43+
Stack (SP) := Value;
44+
SP := SP + 1;
45+
#if Log then
46+
Put_Line ("SP:" & SP_Type'Image (SP));
47+
#end if;
48+
end Push;
49+
50+
begin
51+
52+
#if Log then
53+
Put_Line ("Program starting:");
54+
Put_Line ("PC:" & PC_Type'Image (PC));
55+
Put_Line ("SP:" & SP_Type'Image (SP));
56+
New_Line;
57+
#end if;
58+
59+
while Continue loop
60+
declare
61+
Inst : Instruction_Type renames Program (PC);
62+
Next_PC : PC_Type := PC + 1;
63+
begin
64+
#if Log then
65+
Put_Line
66+
("Execute: "
67+
& Opcode'Image (Inst.Kind)
68+
& " at" & PC_Type'Image (PC));
69+
#end if;
70+
case Inst.Kind is
71+
when Halt =>
72+
Continue := False;
73+
74+
when Jump =>
75+
Next_PC := Inst.Jump_Dest;
76+
77+
when Branch =>
78+
if Pop /= 0 then
79+
Next_PC := Inst.Jump_Dest;
80+
end if;
81+
82+
when Push_Lit =>
83+
Push (Inst.Push_Value);
84+
85+
when Clone =>
86+
declare
87+
Value : constant Integer := Pop;
88+
begin
89+
Push (Value);
90+
Push (Value);
91+
end;
92+
93+
when Add =>
94+
Push (Pop + Pop);
95+
end case;
96+
PC := Next_PC;
97+
end;
98+
end loop;
99+
100+
#if Log then
101+
New_Line;
102+
Put_Line ("Program stopped");
103+
Put_Line ("PC:" & PC_Type'Image (PC));
104+
Put_Line ("SP:" & SP_Type'Image (SP));
105+
#end if;
106+
end Eval;
107+
108+
----------
109+
-- Eval --
110+
----------
111+
112+
function Eval
113+
(Program : Program_Type;
114+
Stack_Size : Natural;
115+
Initial_Values : Stack_Type) return Integer
116+
is
117+
SP_First : constant SP_Type := Initial_Values'First;
118+
SP_Last : constant SP_Type :=
119+
Initial_Values'First + SP_Type (Stack_Size) - 1;
120+
121+
Stack : Stack_Type (SP_First .. SP_Last);
122+
PC : PC_Type := Program'First;
123+
SP : SP_Type := Initial_Values'Last + 1;
124+
begin
125+
Stack (Initial_Values'Range) := Initial_Values;
126+
Eval (Program, PC, Stack, SP);
127+
return Stack (SP - 1);
128+
end Eval;
129+
130+
end VM;

‎testsuite/tests/138-ada-preprocessing/example/vm.ads‎

Lines changed: 30 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,30 @@
1+
package VM is
2+
3+
type PC_Type is new Positive;
4+
type SP_Type is new Positive;
5+
6+
type Opcode is (Halt, Jump, Branch, Push_Lit, Clone, Add);
7+
type Instruction_Type (Kind : Opcode := Opcode'First) is record
8+
case Kind is
9+
when Halt => null;
10+
when Jump | Branch => Jump_Dest : PC_Type;
11+
when Push_Lit => Push_Value : Integer;
12+
when Clone | Add => null;
13+
end case;
14+
end record;
15+
16+
type Stack_Type is array (SP_Type range <>) of Integer;
17+
type Program_Type is array (PC_Type range <>) of Instruction_Type;
18+
19+
procedure Eval
20+
(Program : Program_Type;
21+
PC : in out PC_Type;
22+
Stack : in out Stack_type;
23+
SP : in out SP_Type);
24+
25+
function Eval
26+
(Program : Program_Type;
27+
Stack_Size : Natural;
28+
Initial_Values : Stack_Type) return Integer;
29+
30+
end VM;

0 commit comments

Comments
 (0)