Skip to content

Commit 207b3e0

Browse files
HugoGGuerrierHugoGGuerrier
committed
Merge branch 'topic/kp_20089' into 'master'
Add detector for KP 20089 Closes #551 See merge request eng/libadalang/langkit-query-language!549
2 parents 14a83ed + 3b325a2 commit 207b3e0

File tree

12 files changed

+210
-15
lines changed

12 files changed

+210
-15
lines changed

‎lkql_checker/share/lkql/kp/kp_19915.lkql‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
1-
@check(help="occurrence of KP 19915",
2-
message="occurrence of KP 19915")
1+
@check(help="possible occurrence of KP 19915",
2+
message="possible occurrence of KP 19915")
33
fun kp_19915(node) =
44
|" Search for `'Class'Max_Size_In_Storage_Elements`.
55
node is AttributeRef(f_prefix: prefix@AttributeRef)

‎lkql_checker/share/lkql/kp/kp_20023.lkql‎

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -8,8 +8,8 @@ fun is_class_subtype(type_expr) =
88
| a@AttributeRef => a.f_attribute.p_name_is("class")
99
| i@Identifier => i.p_referenced_decl() is BaseSubtypeDecl(p_get_type(): ClasswideTypeDecl)
1010

11-
@check(help="occurrence of KP 20023",
12-
message="occurrence of KP 20023")
11+
@check(help="possible occurrence of KP 20023",
12+
message="possible occurrence of KP 20023")
1313
fun kp_20023(node) =
1414
|" Flag object assignments to class-wide type objects where the right hand
1515
|" side is a conditional expression containing function calls that dispatch

‎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-19915/test.out‎

Lines changed: 1 addition & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,4 +1,4 @@
1-
main.adb:8:27: rule violation: occurrence of KP 19915
1+
main.adb:8:27: rule violation: possible occurrence of KP 19915
22
8 | Size : Long_Integer := T'Class'Max_Size_In_Storage_Elements; -- FLAG
33
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
44

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

Lines changed: 6 additions & 6 deletions
Original file line numberDiff line numberDiff line change
@@ -1,16 +1,16 @@
1-
main.adb:31:4: rule violation: occurrence of KP 20023
1+
main.adb:31:4: rule violation: possible occurrence of KP 20023
22
31 | X := (if Cond then Make_Dispatch else Make); -- FLAG
33
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
44

5-
main.adb:32:4: rule violation: occurrence of KP 20023
5+
main.adb:32:4: rule violation: possible occurrence of KP 20023
66
32 | X := (if Cond then Make else Make_Dispatch); -- FLAG
77
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
88

9-
main.adb:33:4: rule violation: occurrence of KP 20023
9+
main.adb:33:4: rule violation: possible occurrence of KP 20023
1010
33 | X := ((((if Cond then Make_Dispatch else Make)))); -- FLAG
1111
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
1212

13-
main.adb:34:4: rule violation: occurrence of KP 20023
13+
main.adb:34:4: rule violation: possible occurrence of KP 20023
1414
34 | X := -- FLAG
1515
| ____^
1616
||
@@ -19,11 +19,11 @@ main.adb:34:4: rule violation: occurrence of KP 20023
1919
37 || when False => Make);
2020
||____________________________^
2121

22-
main.adb:38:4: rule violation: occurrence of KP 20023
22+
main.adb:38:4: rule violation: possible occurrence of KP 20023
2323
38 | Y := (if Cond then Make_Dispatch else Make); -- FLAG
2424
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
2525

26-
main.adb:39:4: rule violation: occurrence of KP 20023
26+
main.adb:39:4: rule violation: possible occurrence of KP 20023
2727
39 | Z := (if Cond then Make_Dispatch else Make); -- FLAG
2828
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
2929

‎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+

0 commit comments

Comments
 (0)