Skip to content

Commit 3b325a2

Browse files
HugoGGuerrierHugoGGuerrier
committed
Add detector for KP 20089
1 parent 95341e5 commit 3b325a2

File tree

8 files changed

+195
-0
lines changed

8 files changed

+195
-0
lines changed

‎lkql_checker/share/lkql/kp/kp_20089.lkql‎

Lines changed: 26 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,26 @@
1+
import stdlib
2+
3+
@check(help="possible occurrence of KP 20089",
4+
message="possible occurrence of KP 20089")
5+
fun kp_20089(node) =
6+
|" Flag subprogram calls which have at least one actual parameter passed in
7+
|" ``out`` or ``in out`` mode, while being a type conversion where the
8+
|" target subtype has an enabled predicate. The parameter also have to be
9+
|" not a "by reference" parameter.
10+
node is CallExpr(p_is_call(): true)
11+
when {
12+
val params = node.p_call_params();
13+
stdlib.any([
14+
param.actual is CallExpr(
15+
p_kind(): "type_conversion",
16+
f_name: Name(p_referenced_decl(): d@BaseTypeDecl)
17+
) when stdlib.is_subject_to_predicate(d)
18+
and (
19+
from param.param
20+
through parent
21+
select first ParamSpec
22+
) is s@ParamSpec(f_mode: ModeOut | ModeInOut)
23+
and not stdlib.is_by_ref(param)
24+
for param in params
25+
])
26+
}

‎lkql_checker/share/lkql/stdlib.lkql‎

Lines changed: 30 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -610,6 +610,29 @@ fun is_by_copy(param) =
610610
when t.p_is_discrete_type() or t.p_is_access_type() or
611611
t.p_is_fixed_point() or t.p_is_float_type()
612612

613+
fun is_by_ref(param) =
614+
|" Get whether the provided parameter (a ``ParamActual``) type is a
615+
|" by-reference" type as defined in the reference manual at 6.2(4-9).
616+
{
617+
fun is_type_by_ref(type_decl) =
618+
type_decl is (
619+
BaseTypeDecl(p_is_tagged_type(): true)
620+
| TaskTypeDecl
621+
| ProtectedTypeDecl
622+
| TypeDecl(f_type_def: RecordTypeDef(f_has_limited: LimitedPresent))
623+
| BaseTypeDecl(p_is_private(): true) when is_type_by_ref(type_decl.p_full_view())
624+
| BaseTypeDecl
625+
when is_composite_type(type_decl)
626+
and any([
627+
is_type_by_ref(t)
628+
for t in component_types(type_decl)
629+
])
630+
| SubtypeDecl when is_type_by_ref(type_decl.p_base_subtype())
631+
);
632+
val param_spec = from param.param through parent select first ParamSpec;
633+
is_type_by_ref(param_spec.f_type_expr.p_designated_type_decl())
634+
}
635+
613636
fun get_parameter(params, actual) =
614637
|" Given a ``List[ParamActual]``, return the parameter corresponding to
615638
|" actual, null if actual is not found.
@@ -724,6 +747,13 @@ fun is_tasking_construct(node) =
724747
)
725748
)
726749

750+
fun is_subject_to_predicate(decl) =
751+
|" Return whether the provided declaration is subject to a dynamic or
752+
|" static predicate.
753+
decl.p_has_aspect("predicate")
754+
or decl.p_has_aspect("static_predicate")
755+
or decl.p_has_aspect("dynamic_predicate")
756+
727757
selector component_types
728758
|" Return all the ``BaseTypeDecl`` corresponding to all fields of a given
729759
|" type, including their full views, base types and subtypes.

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

Lines changed: 45 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,45 @@
1+
package body Main is
2+
task body Tsk is
3+
begin
4+
null;
5+
end Tsk;
6+
7+
protected body Prot is
8+
function Get return Integer is
9+
begin
10+
return 0;
11+
end Get;
12+
end Prot;
13+
14+
procedure Test is
15+
B : Base := 1;
16+
TR : Tag_Rec;
17+
T : Tsk;
18+
Pro : Prot;
19+
LR : Lim_Rec;
20+
Pri : Priv;
21+
R : Rec;
22+
A : Arr;
23+
ER : Ext_Rec;
24+
begin
25+
Test_Out (With_Pred (B)); -- FLAG
26+
Test_In_Out (With_Pred (B)); -- FLAG
27+
Test_In_Out (Sub_With_Pred (B)); -- FLAG
28+
Test_In_Out (With_Stat_Pred (B)); -- FLAG
29+
Test_In_Out (With_Dyn_Pred (B)); -- FLAG
30+
31+
Test_In_Out (Base (B)); -- NOFLAG (No predicate)
32+
Test_Default (With_Pred (B)); -- NOFLAG (Default param mode)
33+
Test_In (With_Pred (B)); -- NOFLAG (In param mode)
34+
Test_In_Out (B); -- NOFLAG (No conversion)
35+
Test_Tag_Rec (Sub_Tag_Rec (TR)); -- NOFLAG (By ref type)
36+
Test_Tsk (Sub_Tsk (T)); -- NOFLAG (By ref type)
37+
Test_Sub_Tsk (Sub_Sub_Tsk (T)); -- NOFLAG (By ref type)
38+
Test_Prot (Sub_Prot (Pro)); -- NOFLAG (By ref type)
39+
Test_Lim_Rec (Sub_Lim_rec (LR)); -- NOFLAG (By ref type)
40+
Test_Priv (Sub_Priv (Pri)); -- NOFLAG (By ref type)
41+
Test_Rec (Sub_Rec (R)); -- NOFLAG (By ref type)
42+
Test_Arr (Sub_Arr (A)); -- NOFLAG (By ref type)
43+
Test_Ext_Rec (Sub_Ext_Rec (ER)); -- NOFLAG (By ref type)
44+
end Test;
45+
end Main;

‎testsuite/tests/checks/KP-20089/main.ads‎

Lines changed: 67 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,67 @@
1+
package Main is
2+
procedure Test;
3+
4+
-- Simple range type
5+
type Base is range 1 .. 10;
6+
subtype With_Pred is Base with Predicate => True;
7+
subtype Sub_With_Pred is With_Pred;
8+
subtype With_Stat_Pred is Base with Static_Predicate => True;
9+
subtype With_Dyn_Pred is Base with Dynamic_Predicate => True;
10+
11+
procedure Test_Default (X : Base) is null;
12+
procedure Test_In (X : in Base) is null;
13+
procedure Test_Out (X : out Base) is null;
14+
procedure Test_In_Out (X : in out Base) is null;
15+
16+
-- Tagged record
17+
type Tag_Rec is tagged null record;
18+
subtype Sub_Tag_Rec is Tag_Rec with Predicate => True;
19+
20+
procedure Test_Tag_Rec (X : in out Tag_Rec) is null;
21+
22+
-- Task type
23+
task type Tsk;
24+
subtype Sub_Tsk is Tsk with Predicate => True;
25+
subtype Sub_Sub_Tsk is Sub_Tsk with Predicate => True;
26+
27+
procedure Test_Tsk (X : in out Tsk) is null;
28+
procedure Test_Sub_Tsk (X : in out Sub_Tsk) is null;
29+
30+
-- Protected type
31+
protected type Prot is
32+
function Get return Integer;
33+
end Prot;
34+
subtype Sub_Prot is Prot with Predicate => True;
35+
36+
procedure Test_Prot (X : in out Prot) is null;
37+
38+
-- Limited record type
39+
type Lim_Rec is limited null record;
40+
subtype Sub_Lim_rec is Lim_Rec with Predicate => True;
41+
42+
procedure Test_Lim_Rec (X : in out Lim_Rec) is null;
43+
44+
-- Private type with by reference full view
45+
type Priv is private;
46+
subtype Sub_Priv is Priv with Predicate => True;
47+
48+
procedure Test_Priv (X : in out Priv) is null;
49+
50+
-- Composite type with by reference component
51+
type Rec is record
52+
P : Priv;
53+
end record;
54+
subtype Sub_Rec is Rec with Predicate => True;
55+
56+
type Arr is array (1 .. 1) of Priv;
57+
subtype Sub_Arr is Arr with Predicate => True;
58+
59+
type Ext_Rec is new Tag_Rec with null record;
60+
subtype Sub_Ext_Rec is Ext_Rec with Predicate => True;
61+
62+
procedure Test_Rec (X : in out Rec) is null;
63+
procedure Test_Arr (X : in out Arr) is null;
64+
procedure Test_Ext_Rec (X : in out Ext_Rec) is null;
65+
private
66+
type Priv is tagged null record;
67+
end Main;

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,2 @@
1+
project Prj is
2+
end Prj;

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

Lines changed: 20 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,20 @@
1+
main.adb:25:7: rule violation: possible occurrence of KP 20089
2+
25 | Test_Out (With_Pred (B)); -- FLAG
3+
| ^^^^^^^^^^^^^^^^^^^^^^^^
4+
5+
main.adb:26:7: rule violation: possible occurrence of KP 20089
6+
26 | Test_In_Out (With_Pred (B)); -- FLAG
7+
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^
8+
9+
main.adb:27:7: rule violation: possible occurrence of KP 20089
10+
27 | Test_In_Out (Sub_With_Pred (B)); -- FLAG
11+
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
12+
13+
main.adb:28:7: rule violation: possible occurrence of KP 20089
14+
28 | Test_In_Out (With_Stat_Pred (B)); -- FLAG
15+
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
16+
17+
main.adb:29:7: rule violation: possible occurrence of KP 20089
18+
29 | Test_In_Out (With_Dyn_Pred (B)); -- FLAG
19+
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
20+

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

Lines changed: 3 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,3 @@
1+
driver: checker
2+
rule_name: kp_20089
3+
project: prj.gpr

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -97,6 +97,7 @@ testsuite_driver: No output file generated by gnatcheck
9797
<check switch="+Rkp_19915" label="possible occurrence of KP 19915"/>
9898
<check switch="+Rkp_19997" label="possible occurrence of KP 19997"/>
9999
<check switch="+Rkp_20023" label="possible occurrence of KP 20023"/>
100+
<check switch="+Rkp_20089" label="possible occurrence of KP 20089"/>
100101
<check switch="+Rkp_ob03_009" label="possible occurrence of KP OB03-009"/>
101102
<check switch="+Rkp_p226_024" label="possible occurrence of KP P226-024 - global analysis required"/>
102103
<check switch="+Rkp_q309_014" label="possible occurrence of KP Q309-014"/>
@@ -619,6 +620,7 @@ testsuite_driver: No output file generated by gnatcheck
619620
<check switch="+Rkp_19915" label="possible occurrence of KP 19915"/>
620621
<check switch="+Rkp_19997" label="possible occurrence of KP 19997"/>
621622
<check switch="+Rkp_20023" label="possible occurrence of KP 20023"/>
623+
<check switch="+Rkp_20089" label="possible occurrence of KP 20089"/>
622624
<check switch="+Rkp_ob03_009" label="possible occurrence of KP OB03-009"/>
623625
<check switch="+Rkp_p226_024" label="possible occurrence of KP P226-024 - global analysis required"/>
624626
<check switch="+Rkp_q309_014" label="possible occurrence of KP Q309-014"/>

0 commit comments

Comments
 (0)