Skip to content

Commit 395a244

Browse files
HugoGGuerrierHugoGGuerrier
committed
Add detector for KP-20023
1 parent c59c4b4 commit 395a244

File tree

6 files changed

+102
-0
lines changed

6 files changed

+102
-0
lines changed

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

Lines changed: 23 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,23 @@
1+
import stdlib
2+
3+
fun is_class_subtype(type_expr) =
4+
|" Returns whether the provided type express designate a class-wide
5+
|" subtype.
6+
type_expr is SubtypeIndication when
7+
match type_expr.f_name
8+
| a@AttributeRef => a.f_attribute.p_name_is("class")
9+
| i@Identifier => i.p_referenced_decl() is BaseSubtypeDecl(p_get_type(): ClasswideTypeDecl)
10+
11+
@check(help="occurrence of KP 20023",
12+
message="occurrence of KP 20023")
13+
fun kp_20023(node) =
14+
|" Flag object assignments to class-wide type objects where the right hand
15+
|" side is a conditional expression containing function calls that dispatch
16+
|" on result.
17+
node is AssignStmt when
18+
is_class_subtype(node.f_dest.p_referenced_decl()?.p_type_expression?())
19+
and stdlib.strip_conversions(node.f_expr) is CondExpr
20+
and stdlib.any([
21+
call.p_is_dispatching_call()
22+
for call in from node.f_expr select Name
23+
])

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

Lines changed: 43 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,43 @@
1+
procedure Main is
2+
package Root_Pkg is
3+
type Root is tagged record
4+
X : Integer;
5+
end record;
6+
function Make return Root'Class
7+
is (Root'(X => 1));
8+
function Make_Dispatch return Root
9+
is (X => 0);
10+
end Root_Pkg;
11+
use Root_Pkg;
12+
13+
package Child_Pkg is
14+
type Child is new Root with null record;
15+
overriding
16+
function Make_Dispatch return Child
17+
is (X => -1);
18+
end Child_Pkg;
19+
20+
subtype Sub_Root is Root'Class;
21+
subtype Sub_Sub_Root is Sub_Root;
22+
23+
X : Root'Class := Child_Pkg.Child'(X => 1);
24+
Y : Sub_Root := Child_Pkg.Child'(X => 1);
25+
Z : Sub_Sub_Root := Child_Pkg.Child'(X => 1);
26+
27+
Not_Class : Root := Root'(X => 1);
28+
29+
Cond : Boolean := False;
30+
begin
31+
X := (if Cond then Make_Dispatch else Make); -- FLAG
32+
X := (if Cond then Make else Make_Dispatch); -- FLAG
33+
X := ((((if Cond then Make_Dispatch else Make)))); -- FLAG
34+
X := -- FLAG
35+
(case Cond is
36+
when True => Make_Dispatch,
37+
when False => Make);
38+
Y := (if Cond then Make_Dispatch else Make); -- FLAG
39+
Z := (if Cond then Make_Dispatch else Make); -- FLAG
40+
X := (if Cond then Make else Make); -- NOFLAG
41+
X := Make_Dispatch; -- NOFLAG
42+
Not_Class := (if Cond then Make_Dispatch else Make); -- NOFLAG
43+
end Main;

‎testsuite/tests/checks/KP-20023/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-20023/test.out‎

Lines changed: 29 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,29 @@
1+
main.adb:31:4: rule violation: occurrence of KP 20023
2+
31 | X := (if Cond then Make_Dispatch else Make); -- FLAG
3+
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
4+
5+
main.adb:32:4: rule violation: occurrence of KP 20023
6+
32 | X := (if Cond then Make else Make_Dispatch); -- FLAG
7+
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
8+
9+
main.adb:33:4: rule violation: occurrence of KP 20023
10+
33 | X := ((((if Cond then Make_Dispatch else Make)))); -- FLAG
11+
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
12+
13+
main.adb:34:4: rule violation: occurrence of KP 20023
14+
34 | X := -- FLAG
15+
| ____^
16+
||
17+
|| ~~~ 2 other lines ~~~
18+
||
19+
37 || when False => Make);
20+
||____________________________^
21+
22+
main.adb:38:4: rule violation: occurrence of KP 20023
23+
38 | Y := (if Cond then Make_Dispatch else Make); -- FLAG
24+
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
25+
26+
main.adb:39:4: rule violation: occurrence of KP 20023
27+
39 | Z := (if Cond then Make_Dispatch else Make); -- FLAG
28+
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
29+

‎testsuite/tests/checks/KP-20023/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_20023
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
@@ -95,6 +95,7 @@ testsuite_driver: No output file generated by gnatcheck
9595
<check switch="+Rkp_19853" label="possible occurrence of KP 19853"/>
9696
<check switch="+Rkp_19901" label="possible occurrence of KP 19901"/>
9797
<check switch="+Rkp_19915" label="occurrence of KP 19915"/>
98+
<check switch="+Rkp_20023" label="occurrence of KP 20023"/>
9899
<check switch="+Rkp_ob03_009" label="possible occurrence of KP OB03-009"/>
99100
<check switch="+Rkp_p226_024" label="possible occurrence of KP P226-024 - global analysis required"/>
100101
<check switch="+Rkp_q309_014" label="possible occurrence of KP Q309-014"/>
@@ -615,6 +616,7 @@ testsuite_driver: No output file generated by gnatcheck
615616
<check switch="+Rkp_19853" label="possible occurrence of KP 19853"/>
616617
<check switch="+Rkp_19901" label="possible occurrence of KP 19901"/>
617618
<check switch="+Rkp_19915" label="occurrence of KP 19915"/>
619+
<check switch="+Rkp_20023" label="occurrence of KP 20023"/>
618620
<check switch="+Rkp_ob03_009" label="possible occurrence of KP OB03-009"/>
619621
<check switch="+Rkp_p226_024" label="possible occurrence of KP P226-024 - global analysis required"/>
620622
<check switch="+Rkp_q309_014" label="possible occurrence of KP Q309-014"/>

0 commit comments

Comments
 (0)