Skip to content

Commit 42003dd

Browse files
Jugst3rJugst3r
committed
Merge branch 'eyraud/merge_edge_into_master' into 'master'
Merge edge into master See merge request eng/das/cov/gnatcoverage!323 Ref: eng/it/anod#209
2 parents 4f4513c + 13175e2 commit 42003dd

37 files changed

+1169
-311
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)