Skip to content

Commit dd3b698

Browse files
HugoGGuerrierHugoGGuerrier
committed
Merge branch 'topic/kp_19696' into 'master'
Add detector for KP-19696 Closes #430 See merge request eng/libadalang/langkit-query-language!390
2 parents d84c9a7 + 57e0b37 commit dd3b698

File tree

6 files changed

+145
-0
lines changed

6 files changed

+145
-0
lines changed

‎lkql_checker/share/lkql/kp/KP-19696.lkql

+31
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,31 @@
1+
import stdlib
2+
3+
fun size_depends_on_discriminant(type_decl) =
4+
|" Returns whether the given type declaration is a record declaration with
5+
|" its size depending on defaulted discriminants.
6+
type_decl.p_is_record_type()
7+
and stdlib.any([
8+
d is DiscriminantSpec(f_default_expr: not null)
9+
when (
10+
from type_decl select (
11+
VariantPart(f_discr_name: id when id.p_referenced_decl() == d)
12+
| Constraint(any children: id@Identifier when id.p_referenced_decl() == d)
13+
)
14+
).length > 0
15+
for d in type_decl.p_discriminants_list(type_decl)
16+
])
17+
18+
@check(help="possible occurrence of KP 19696",
19+
message="possible occurrence of KP 19696")
20+
fun kp_19696(node) =
21+
|" Flag function calls returning a discriminated limited record type with
22+
|" default discriminants, with a size that depends on the discriminants.
23+
node is Name(
24+
p_is_call(): true,
25+
p_expression_type(): d@BaseTypeDecl(
26+
p_is_limited_type(): true
27+
) when stdlib.any([
28+
size_depends_on_discriminant(pt)
29+
for pt in [d] & stdlib.full_parent_types(d).to_list
30+
])
31+
)

‎testsuite/tests/checks/KP-19696/main.adb

+79
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,79 @@
1+
procedure Main is
2+
type R_1 (B : Boolean := False) is limited record
3+
case B is
4+
when True =>
5+
I : Integer;
6+
when others =>
7+
F : Float;
8+
end case;
9+
end record;
10+
subtype S_R_1 is R_1;
11+
type D_R_1 is new R_1;
12+
type L_D_R_1 is limited new R_1;
13+
14+
type Int_Arr is array (Integer range <>) of Integer;
15+
type R_2 (I : Integer := 2) is limited record
16+
A : Int_Arr (1 .. I);
17+
end record;
18+
type R_3 (I : Integer) is limited record
19+
A : Int_Arr (1 .. I);
20+
end record;
21+
type R_4 (I : Integer := 2) is record
22+
A : Int_Arr (1 .. I);
23+
end record;
24+
25+
type R_5 (I : Integer := 2) is limited record
26+
A : Int_Arr (1 .. 4);
27+
end record;
28+
29+
type R_6 is tagged limited record
30+
B : Boolean;
31+
end record;
32+
type D_R_6 (I : Integer := 2) is new R_6 with record
33+
A : Int_Arr (1 .. I);
34+
end record;
35+
subtype S_D_R_6 is D_R_6;
36+
37+
function Get_R_1 return R_1 is
38+
(B => True, I => 0);
39+
function Get_S_R_1 return S_R_1 is
40+
(B => True, I => 0);
41+
function Get_D_R_1 return D_R_1 is
42+
(B => True, I => 0);
43+
function Get_L_D_R_1 return L_D_R_1 is
44+
(B => True, I => 0);
45+
function Get_R_2 return R_2 is
46+
(I => 4, A => (others => 0));
47+
function Get_R_3 return R_3 is
48+
(I => 4, A => (others => 0));
49+
function Get_R_4 return R_4 is
50+
(I => 4, A => (others => 0));
51+
function Get_R_5 return R_5 is
52+
(I => 4, A => (others => 0));
53+
function Get_D_R_6 return D_R_6 is
54+
(B => False, I => 4, A => (others => 0));
55+
function Get_S_D_R_6 return S_D_R_6 is
56+
(B => False, I => 4, A => (others => 0));
57+
58+
procedure Consume_R_1 (R : R_1) is null;
59+
procedure Consume_S_R_1 (R : S_R_1) is null;
60+
procedure Consume_D_R_1 (R : D_R_1) is null;
61+
procedure Consume_L_D_R_1 (R : L_D_R_1) is null;
62+
procedure Consume_R_2 (R : R_2) is null;
63+
procedure Consume_R_3 (R : R_3) is null;
64+
procedure Consume_R_4 (R : R_4) is null;
65+
procedure Consume_R_5 (R : R_5) is null;
66+
procedure Consume_D_R_6 (R : D_R_6) is null;
67+
procedure Consume_S_D_R_6 (R : S_D_R_6) is null;
68+
begin
69+
Consume_R_1 (Get_R_1); -- FLAG
70+
Consume_S_R_1 (Get_S_R_1); -- FLAG
71+
Consume_D_R_1 (Get_D_R_1); -- FLAG
72+
Consume_L_D_R_1 (Get_L_D_R_1); -- FLAG
73+
Consume_R_2 (Get_R_2); -- FLAG
74+
Consume_R_3 (Get_R_3); -- NOFLAG
75+
Consume_R_4 (Get_R_4); -- NOFLAG
76+
Consume_R_5 (Get_R_5); -- NOFLAG
77+
Consume_D_R_6 (Get_D_R_6); -- FLAG
78+
Consume_S_D_R_6 (Get_S_D_R_6); -- FLAG
79+
end Main;

‎testsuite/tests/checks/KP-19696/prj.gpr

+2
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,2 @@
1+
project Prj is
2+
end Prj;

‎testsuite/tests/checks/KP-19696/test.out

+28
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,28 @@
1+
main.adb:69:17: rule violation: possible occurrence of KP 19696
2+
69 | Consume_R_1 (Get_R_1); -- FLAG
3+
| ^^^^^^^
4+
5+
main.adb:70:19: rule violation: possible occurrence of KP 19696
6+
70 | Consume_S_R_1 (Get_S_R_1); -- FLAG
7+
| ^^^^^^^^^
8+
9+
main.adb:71:19: rule violation: possible occurrence of KP 19696
10+
71 | Consume_D_R_1 (Get_D_R_1); -- FLAG
11+
| ^^^^^^^^^
12+
13+
main.adb:72:21: rule violation: possible occurrence of KP 19696
14+
72 | Consume_L_D_R_1 (Get_L_D_R_1); -- FLAG
15+
| ^^^^^^^^^^^
16+
17+
main.adb:73:17: rule violation: possible occurrence of KP 19696
18+
73 | Consume_R_2 (Get_R_2); -- FLAG
19+
| ^^^^^^^
20+
21+
main.adb:77:19: rule violation: possible occurrence of KP 19696
22+
77 | Consume_D_R_6 (Get_D_R_6); -- FLAG
23+
| ^^^^^^^^^
24+
25+
main.adb:78:21: rule violation: possible occurrence of KP 19696
26+
78 | Consume_S_D_R_6 (Get_S_D_R_6); -- FLAG
27+
| ^^^^^^^^^^^
28+

‎testsuite/tests/checks/KP-19696/test.yaml

+3
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
driver: checker
2+
rule_name: kp_19696
3+
project: prj.gpr

‎testsuite/tests/gnatcheck/xml_help/test.out

+2
Original file line numberDiff line numberDiff line change
@@ -86,6 +86,7 @@ testsuite_driver: No output file generated by gnatcheck
8686
<check switch="+Rkp_19447" label="possible occurrence of KP 19447"/>
8787
<check switch="+Rkp_19501" label="possible occurrence of KP 19501"/>
8888
<check switch="+Rkp_19529" label="possible occurrence of KP 19529"/>
89+
<check switch="+Rkp_19696" label="possible occurrence of KP 19696"/>
8990
<check switch="+Rkp_ob03_009" label="possible occurrence of KP OB03-009"/>
9091
<check switch="+Rkp_p226_024" label="possible occurrence of KP P226-024 - global analysis required"/>
9192
<check switch="+Rkp_q309_014" label="possible occurrence of KP Q309-014"/>
@@ -594,6 +595,7 @@ testsuite_driver: No output file generated by gnatcheck
594595
<check switch="+Rkp_19447" label="possible occurrence of KP 19447"/>
595596
<check switch="+Rkp_19501" label="possible occurrence of KP 19501"/>
596597
<check switch="+Rkp_19529" label="possible occurrence of KP 19529"/>
598+
<check switch="+Rkp_19696" label="possible occurrence of KP 19696"/>
597599
<check switch="+Rkp_ob03_009" label="possible occurrence of KP OB03-009"/>
598600
<check switch="+Rkp_p226_024" label="possible occurrence of KP P226-024 - global analysis required"/>
599601
<check switch="+Rkp_q309_014" label="possible occurrence of KP Q309-014"/>

0 commit comments

Comments
 (0)