Skip to content

Commit 984fc17

Browse files
raph-amiardraph-amiard
committed
Add Overriding_Marks check
1 parent b14a744 commit 984fc17

File tree

9 files changed

+264
-0
lines changed

9 files changed

+264
-0
lines changed

‎lkql_checker/doc/generated/list_of_rules.rst‎

Lines changed: 1 addition & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -139,6 +139,7 @@ GNATcheck rules.
139139
* :ref:`Overloaded_Operators`
140140
* :ref:`Overly_Nested_Control_Structures`
141141
* :ref:`Overly_Nested_Scopes`
142+
* :ref:`Overriding_Marks`
142143
* :ref:`Parameters_Aliasing`
143144
* :ref:`Parameters_Out_Of_Order`
144145
* :ref:`POS_On_Enumeration_Types`

‎lkql_checker/doc/generated/predefined_rules.rst‎

Lines changed: 35 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -6215,6 +6215,41 @@ first construct is flagged
62156215
62166216
62176217
6218+
.. _Overriding_Marks:
6219+
6220+
``Overriding_Marks``
6221+
^^^^^^^^^^^^^^^^^^^^
6222+
6223+
.. index:: Overriding_Marks
6224+
6225+
Check that overriding subprograms are explicitly marked as such.
6226+
6227+
This applies to all subprograms of a derived type that override a
6228+
primitive operation of the type, for both tagged and untagged types. In
6229+
particular, the declaration of a primitive operation of a type extension
6230+
that overrides an inherited operation must carry an overriding
6231+
indicator. Another case is the declaration of a function that overrides
6232+
a predefined operator (such as an equality operator).
6233+
6234+
.. attention:: This doesn't apply to primitives of multiple untagged
6235+
types, and as such, won't ever flag such overriding primitives.
6236+
6237+
.. rubric:: Example
6238+
6239+
.. code-block:: ada
6240+
:emphasize-lines: 7
6241+
6242+
package Foo is
6243+
type A is null record;
6244+
procedure Prim (Self : A) is null;
6245+
6246+
type B is new A;
6247+
6248+
procedure Prim (Self : B) is null; -- FLAG
6249+
end Foo;
6250+
6251+
6252+
62186253
.. _Profile_Discrepancies:
62196254

62206255
``Profile_Discrepancies``

‎lkql_checker/share/lkql/overriding_marks.lkql‎

Lines changed: 87 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,87 @@
1+
import stdlib
2+
3+
@memoized
4+
fun range(n) =
5+
|" Quick and dirty range function. Made to work-around the absence of
6+
|" iterator.enumerate in GNATcheck 24.3
7+
if n == 0 then [] else range(n - 1) & [n]
8+
9+
fun match_signature(child_prim, parent_prim, child_type, parent_type) =
10+
|" Custom signature matching function, made to handle the fact that in 24.3
11+
|" LAL's base_subp_declarations doesn't work.
12+
{
13+
14+
fun match_types(child_ptype, parent_ptype) =
15+
# Regular match types, except in the case where the parameter types
16+
# match the controlling type
17+
child_ptype.p_matching_type(parent_ptype)
18+
or (child_ptype.p_matching_type(child_type)
19+
and parent_ptype.p_matching_type(parent_type));
20+
21+
# Check that the names are the same
22+
child_prim.p_defining_name().p_name_matches(parent_prim.p_defining_name())
23+
24+
and {
25+
val child_spec = child_prim.p_subp_spec_or_null();
26+
val parent_spec = parent_prim.p_subp_spec_or_null();
27+
28+
val child_params = child_spec.p_formal_params();
29+
val parent_params = parent_spec.p_formal_params();
30+
31+
# Check that return type is the same
32+
((child_spec.p_returns() is null and parent_spec.p_returns() is null)
33+
or (child_spec.p_returns() is not null and parent_spec.p_returns() is not null
34+
and match_types(child_spec.p_returns().p_designated_type_decl(),
35+
parent_spec.p_returns().p_designated_type_decl())))
36+
37+
# Check that parameters types are the same
38+
and child_params.length == parent_params.length
39+
and stdlib.all([match_types(child_params[i].p_basic_decl().p_formal_type(),
40+
parent_params[i].p_basic_decl().p_formal_type())
41+
for i in range(child_params.length)])
42+
}
43+
}
44+
45+
@check(category="Style", subcategory="Readability", message="Missing overriding mark")
46+
fun overriding_marks(node) =
47+
|" Check that overriding subprograms are explicitly marked as such.
48+
|"
49+
|" This applies to all subprograms of a derived type that override a
50+
|" primitive operation of the type, for both tagged and untagged types. In
51+
|" particular, the declaration of a primitive operation of a type extension
52+
|" that overrides an inherited operation must carry an overriding
53+
|" indicator. Another case is the declaration of a function that overrides
54+
|" a predefined operator (such as an equality operator).
55+
|"
56+
|" .. attention:: This doesn't apply to primitives of multiple untagged
57+
|" types, and as such, won't ever flag such overriding primitives.
58+
|"
59+
|" .. rubric:: Example
60+
|"
61+
|" .. code-block:: ada
62+
|" :emphasize-lines: 7
63+
|"
64+
|" package Foo is
65+
|" type A is null record;
66+
|" procedure Prim (Self : A) is null;
67+
|"
68+
|" type B is new A;
69+
|"
70+
|" procedure Prim (Self : B) is null; -- FLAG
71+
|" end Foo;
72+
# Select primitives subprograms
73+
node is (BasicSubpDecl | BaseSubpBody) (
74+
p_subp_spec_or_null(): BaseSubpSpec(
75+
p_primitive_subp_first_type(): t@TypeDecl(
76+
p_base_type(): bt@TypeDecl(
77+
p_get_primitives(): primitives@(not null)
78+
when stdlib.any([p for p in primitives if match_signature(node, p, t, bt)])
79+
)
80+
)
81+
),
82+
f_overriding: OverridingUnspecified
83+
)
84+
85+
# Body stubs can also take an "overriding" indicator. In that case, check
86+
# the body.
87+
or node is SubpBodyStub(p_previous_part_for_decl(): dcl) when overriding_marks(dcl)

‎testsuite/tests/checks/overriding_marks/test-prim3.adb‎

Lines changed: 5 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,5 @@
1+
separate (Test)
2+
procedure Prim3 (Self : T6; Other : Integer) is
3+
begin
4+
null;
5+
end Prim3;

‎testsuite/tests/checks/overriding_marks/test.adb‎

Lines changed: 49 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,49 @@
1+
package body Test is
2+
procedure Prim1 (Self : T1; Other : Integer) is null;
3+
function Prim2 (Self : T1; Other : Integer) return String
4+
is
5+
begin
6+
return "hello";
7+
end Prim2;
8+
9+
procedure Prim1 (Self : T2; Other : Integer) is null; -- FLAG
10+
function Prim2 (Self : T2; Other : Integer) return String
11+
is
12+
begin
13+
return "hello";
14+
end Prim2; -- FLAG
15+
16+
overriding procedure Prim1 (Self : T3; Other : Integer) is null; -- NOFLAG
17+
overriding function Prim2 (Self : T3; Other : Integer) return String
18+
is
19+
begin
20+
return "hello";
21+
end Prim2; -- NOFLAG
22+
23+
procedure Not_A_Prim (Self : Integer) is null; -- NOFLAG
24+
25+
procedure Prim1 (Self : T4; Other : Integer) is null;
26+
function Prim2 (Self : T4; Other : Integer) return String
27+
is
28+
begin
29+
return "hello";
30+
end Prim2;
31+
32+
overriding procedure Prim1 (Self : T5; Other : Integer) is null; -- NOFLAG
33+
overriding function Prim2 (Self : T5; Other : Integer) return String
34+
is
35+
begin
36+
return "hello";
37+
end Prim2; -- NOFLAG
38+
39+
procedure Prim1 (Self : T6; Other : Integer) is null; -- FLAG
40+
function Prim2 (Self : T6; Other : Integer) return String
41+
is
42+
begin
43+
return "hello";
44+
end Prim2; -- FLAG
45+
46+
procedure Prim3 (Self : T4; Other : Integer) is null;
47+
48+
procedure Prim3 (Self : T6; Other : Integer) is separate;
49+
end Test;

‎testsuite/tests/checks/overriding_marks/test.ads‎

Lines changed: 34 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,34 @@
1+
package Test is
2+
type T1 is null record;
3+
procedure Prim1 (Self : T1; Other : Integer);
4+
function Prim2 (Self : T1; Other : Integer) return String;
5+
function Prim4 (Self : T1) return Integer is (10);
6+
7+
type T2 is new T1;
8+
procedure Prim1 (Self : T2; Other : Integer); -- FLAG
9+
function Prim2 (Self : T2; Other : Integer) return String; -- FLAG
10+
procedure Prim3 (Self : T2; Other : Integer) is null; -- NOFLAG
11+
function Prim4 (Self : T2) return Integer is (12) -- FLAG;
12+
13+
type T3 is new T1;
14+
overriding procedure Prim1 (Self : T3; Other : Integer); -- NOFLAG
15+
overriding function Prim2 (Self : T3; Other : Integer) return String; -- NOFLAG
16+
overriding function Prim4 (Self : T3) return Integer is (12) -- NOFLAG;
17+
18+
procedure Not_A_Prim (Self : Integer); -- NOFLAG
19+
20+
type T4 is tagged null record;
21+
procedure Prim1 (Self : T4; Other : Integer);
22+
function Prim2 (Self : T4; Other : Integer) return String;
23+
procedure Prim3 (Self : T4; Other : Integer);
24+
25+
type T5 is new T4 with null record;
26+
overriding procedure Prim1 (Self : T5; Other : Integer); -- NOFLAG
27+
overriding function Prim2 (Self : T5; Other : Integer) return String; -- NOFLAG
28+
29+
type T6 is new T4 with null record;
30+
procedure Prim1 (Self : T6; Other : Integer); -- FLAG
31+
function Prim2 (Self : T6; Other : Integer) return String; -- FLAG
32+
procedure Prim3 (Self : T6; Other : Integer); -- FLAG
33+
34+
end Test;

‎testsuite/tests/checks/overriding_marks/test.out‎

Lines changed: 48 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,48 @@
1+
test.ads:8:14: rule violation: Missing overriding mark
2+
8 | procedure Prim1 (Self : T2; Other : Integer); -- FLAG
3+
| ^^^^^
4+
5+
test.ads:9:13: rule violation: Missing overriding mark
6+
9 | function Prim2 (Self : T2; Other : Integer) return String; -- FLAG
7+
| ^^^^^
8+
9+
test.ads:11:13: rule violation: Missing overriding mark
10+
11 | function Prim4 (Self : T2) return Integer is (12) -- FLAG;
11+
| ^^^^^
12+
13+
test.ads:30:14: rule violation: Missing overriding mark
14+
30 | procedure Prim1 (Self : T6; Other : Integer); -- FLAG
15+
| ^^^^^
16+
17+
test.ads:31:13: rule violation: Missing overriding mark
18+
31 | function Prim2 (Self : T6; Other : Integer) return String; -- FLAG
19+
| ^^^^^
20+
21+
test.ads:32:14: rule violation: Missing overriding mark
22+
32 | procedure Prim3 (Self : T6; Other : Integer); -- FLAG
23+
| ^^^^^
24+
25+
test.adb:9:14: rule violation: Missing overriding mark
26+
9 | procedure Prim1 (Self : T2; Other : Integer) is null; -- FLAG
27+
| ^^^^^
28+
29+
test.adb:10:13: rule violation: Missing overriding mark
30+
10 | function Prim2 (Self : T2; Other : Integer) return String
31+
| ^^^^^
32+
33+
test.adb:39:14: rule violation: Missing overriding mark
34+
39 | procedure Prim1 (Self : T6; Other : Integer) is null; -- FLAG
35+
| ^^^^^
36+
37+
test.adb:40:13: rule violation: Missing overriding mark
38+
40 | function Prim2 (Self : T6; Other : Integer) return String
39+
| ^^^^^
40+
41+
test.adb:48:14: rule violation: Missing overriding mark
42+
48 | procedure Prim3 (Self : T6; Other : Integer) is separate;
43+
| ^^^^^
44+
45+
test-prim3.adb:2:11: rule violation: Missing overriding mark
46+
2 | procedure Prim3 (Self : T6; Other : Integer) is
47+
| ^^^^^
48+

‎testsuite/tests/checks/overriding_marks/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: overriding_marks
3+
input_sources: ['test.ads', 'test.adb', 'test-prim3.adb']

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

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -394,6 +394,7 @@ testsuite_driver: No output file generated by gnatcheck
394394
<check switch="+Rnumeric_format" label="incorrect format for numeric literal"/>
395395
<check switch="+Robject_declarations_out_of_order" label="object declarations should precede program unit declarations"/>
396396
<check switch="+Rone_construct_per_line" label="more than one construct on the same line"/>
397+
<check switch="+Roverriding_marks" label="Missing overriding mark"/>
397398
<check switch="+Rprofile_discrepancies" label="parameter profile discrepancies"/>
398399
<check switch="+Runcommented_begin" label="BEGIN not marked with entity name comment"/>
399400
<check switch="+Runcommented_begin_in_package_bodies" label="BEGIN in package bodies not marked with package name comment"/>
@@ -908,6 +909,7 @@ testsuite_driver: No output file generated by gnatcheck
908909
<check switch="+Rnumeric_format" label="incorrect format for numeric literal"/>
909910
<check switch="+Robject_declarations_out_of_order" label="object declarations should precede program unit declarations"/>
910911
<check switch="+Rone_construct_per_line" label="more than one construct on the same line"/>
912+
<check switch="+Roverriding_marks" label="Missing overriding mark"/>
911913
<check switch="+Rprofile_discrepancies" label="parameter profile discrepancies"/>
912914
<check switch="+Runcommented_begin" label="BEGIN not marked with entity name comment"/>
913915
<check switch="+Runcommented_begin_in_package_bodies" label="BEGIN in package bodies not marked with package name comment"/>

0 commit comments

Comments
 (0)