-
Notifications
You must be signed in to change notification settings - Fork 5
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
- Loading branch information
1 parent
7d0e0ff
commit 20546be
Showing
6 changed files
with
239 additions
and
0 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,49 @@ | ||
# Flag subprogram bodies which override and have a formal parameter of a | ||
# mutable discriminant type which is assigned in the body. | ||
|
||
import stdlib | ||
|
||
fun is_assigned(id, body) = | ||
|" Get if the given DefiningName identifier is used as LHS in an assignment | ||
|" statement in the provided HandledStatements. | ||
{ | ||
# Get the statements in the subp body and its exception handlers | ||
val stmts = body.f_stmts.children | ||
& concat([eh.f_stmts.children | ||
for eh in body.f_exceptions.children | ||
if eh is ExceptionHandler].to_list); | ||
stdlib.any([s is AssignStmt when s.f_dest.p_referenced_defining_name == id | ||
for s in stmts]) | ||
} | ||
|
||
fun is_unconstrained_discriminated(type_decl) = | ||
|" Get if the given BaseTypeDecl is an unconstrained type with a default valued | ||
|" discriminant. | ||
match type_decl | ||
| SubtypeDecl => not type_decl.f_subtype.p_subtype_constraint() | ||
and is_unconstrained_discriminated(type_decl.p_get_type()) | ||
| BaseTypeDecl(p_base_type() is not null) | ||
=> not type_decl.f_type_def.f_subtype_indication.p_subtype_constraint() | ||
and is_unconstrained_discriminated(type_decl.p_base_type()) | ||
| BaseTypeDecl(p_private_completion() is not null) | ||
=> is_unconstrained_discriminated(type_decl.p_private_completion()) | ||
# TODO: Remove the 'p_discriminants_list' parameter when langkit#776 will be resolved | ||
| BaseTypeDecl => stdlib.any([d.f_default_expr != null | ||
for d in type_decl.p_discriminants_list(type_decl.p_root_type())]) | ||
| * => false | ||
|
||
@check(help="possible occurrence of KP 19142", | ||
message="possible occurrence of KP 19142", | ||
impact="24.*") | ||
fun kp_19142(node) = | ||
node is SubpBody | ||
# Check that the subprogram is overriding | ||
when node.p_root_subp_declarations() | ||
# Check that the subprogram hasn't been declared earlier, otherwise the KP | ||
# won't happen. | ||
and not node.p_decl_part() | ||
and stdlib.any([stdlib.any([is_assigned(id, node.f_stmts) | ||
for id in p.f_ids.children]) | ||
for p in node.f_subp_spec.p_params() | ||
if is_unconstrained_discriminated(p.p_formal_type()) | ||
and p.f_mode is (ModeOut or ModeInOut)]) |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,101 @@ | ||
with Ada.Unchecked_Conversion; | ||
|
||
package body Main is | ||
package body Types is | ||
function New_Private_Mutable return Private_Mutable is | ||
(True, Char_Comp => 'A'); | ||
end Types; | ||
|
||
package body Tests is | ||
-- Test implicit overriding | ||
procedure Test_Implicit (I : Impl; Mut : out Mutable) is -- NOFLAG | ||
begin | ||
Mut := (True, Char_Comp => 'A'); | ||
end Test_Implicit; | ||
|
||
type Implicit is new Implicit_Base with null record; | ||
procedure Test_Implicit (I : Implicit; Mut : out Mutable) is -- FLAG | ||
begin | ||
Mut := (True, Char_Comp => 'A'); | ||
end Test_Implicit; | ||
|
||
procedure Not_Overriding (I : Implicit; Mut : out Mutable) is -- NOFLAG | ||
begin | ||
Mut := (True, Char_Comp => 'A'); | ||
end Not_Overriding; | ||
|
||
-- Test explicit overriding | ||
type Explicit is new Explicit_Base with null record; | ||
overriding procedure Test_Explicit (I : Explicit; Mut : out Mutable) is -- FLAG | ||
begin | ||
Mut := (True, Char_Comp => 'A'); | ||
end Test_Explicit; | ||
|
||
-- Test explicit with early overriding | ||
type Explicit_Early is new Explicit_Base with null record; | ||
overriding procedure Test_Explicit (I : Explicit_Early; Mut : out Mutable); | ||
overriding procedure Test_Explicit (I : Explicit_Early; Mut : out Mutable) is -- NOFLAG | ||
begin | ||
Mut := (True, Char_Comp => 'A'); | ||
end Test_Explicit; | ||
|
||
-- Test subtyping | ||
type Sub is new Sub_Base with null record; | ||
procedure Test_Subtype (I : Sub; Mut : out Sub_Mutable) is -- FLAG | ||
begin | ||
Mut := (True, Char_Comp => 'A'); | ||
end Test_Subtype; | ||
|
||
-- Test derived type | ||
type Derived is new Derived_Base with null record; | ||
procedure Test_Derived (I : Derived; Mut : out Derived_Mutable) is -- FLAG | ||
begin | ||
Mut := (True, Char_Comp => 'A'); | ||
end Test_Derived; | ||
|
||
-- Test private type | ||
type Priv is new Private_Base with null record; | ||
procedure Test_Private (I : Priv; Mut: out Private_Mutable) is -- FLAG | ||
begin | ||
Mut := New_Private_Mutable; | ||
end Test_Private; | ||
|
||
-- Test read and write mutable parameter | ||
type Read_And_Write is new Read_And_Write_Base with null record; | ||
procedure Test_Read_And_Write (I : Read_And_Write; Mut : in out Mutable) is -- FLAG | ||
begin | ||
Mut := (True, Char_Comp => 'A'); | ||
end Test_Read_And_Write; | ||
|
||
-- Test assignment in exception handler | ||
type Exc_Hand is new Exc_Hand_Base with null record; | ||
procedure Test_Exc_Hand (I : Exc_Hand; Mut : out Mutable) is -- FLAG | ||
begin | ||
null; | ||
exception | ||
when others => | ||
Mut := (True, Char_Comp => 'A'); | ||
end Test_Exc_Hand; | ||
|
||
-- Test non mutable discrimant | ||
type Not_Mut is new Not_Mut_Base with null record; | ||
procedure Test_Not_Mut (I : Not_Mut; NM : out Not_Mutable) is -- NOFLAG | ||
begin | ||
NM := (True, Char_Comp => 'A'); | ||
end Test_Not_Mut; | ||
|
||
-- Test constrained subtype | ||
type Constrained is new Constrained_Base with null record; | ||
procedure Test_Constrained (I : Constrained; Const : out Constrained_Rec) is -- NOFLAG | ||
begin | ||
Const := (True, Char_Comp => 'A'); | ||
end Test_Constrained; | ||
|
||
-- Test constrained derived | ||
type Derived_Constrained is new Derived_Constrained_Base with null record; | ||
procedure Test_Derived_Constrained (I : Derived_Constrained; Const : out Derived_Constrained_Rec) is -- NOFLAG | ||
begin | ||
Const := (True, Char_Comp => 'A'); | ||
end Test_Derived_Constrained; | ||
end Tests; | ||
end Main; |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,84 @@ | ||
package Main is | ||
|
||
package Types is | ||
type Not_Mutable (Cond : Boolean) is record | ||
case Cond is | ||
when True => | ||
Char_Comp : Character; | ||
when False => | ||
Int_Comp : Integer; | ||
end case; | ||
end record; | ||
|
||
type Mutable (Cond : Boolean := True) is record | ||
case Cond is | ||
when True => | ||
Char_Comp : Character; | ||
when False => | ||
Int_Comp : Integer; | ||
end case; | ||
end record; | ||
|
||
subtype Sub_Mutable is Mutable; | ||
|
||
type Derived_Mutable is new Sub_Mutable; | ||
|
||
type Private_Mutable is private; | ||
|
||
subtype Constrained_Rec is Mutable (True); | ||
|
||
type Derived_Constrained_Rec is new Mutable (True); | ||
|
||
function New_Private_Mutable return Private_Mutable; | ||
private | ||
type Private_Mutable is new Derived_Mutable; | ||
end Types; | ||
|
||
package Tests is | ||
use Types; | ||
|
||
-- Implicit overriding | ||
type Implicit_Base is interface; | ||
procedure Test_Implicit (I : Implicit_Base; Mut : out Mutable) is abstract; | ||
|
||
type Impl is new Implicit_Base with null record; | ||
procedure Test_Implicit (I : Impl; Mut : out Mutable); | ||
|
||
-- Explicit overriding | ||
type Explicit_Base is interface; | ||
procedure Test_Explicit (I : Explicit_Base; Mut : out Mutable) is abstract; | ||
|
||
-- Subtype | ||
type Sub_Base is interface; | ||
procedure Test_Subtype (I : Sub_Base; Mut : out Sub_Mutable) is abstract; | ||
|
||
-- Derived | ||
type Derived_Base is interface; | ||
procedure Test_Derived (I : Derived_Base; Mut : out Derived_Mutable) is abstract; | ||
|
||
-- Private | ||
type Private_Base is interface; | ||
procedure Test_Private (I : Private_Base; Mut : out Private_Mutable) is abstract; | ||
|
||
-- Read and write | ||
type Read_And_Write_Base is interface; | ||
procedure Test_Read_And_Write (I : Read_And_Write_Base; Mut : in out Mutable) is abstract; | ||
|
||
-- Exception handler | ||
type Exc_Hand_Base is interface; | ||
procedure Test_Exc_Hand (I : Exc_Hand_Base; Mut : out Mutable) is abstract; | ||
|
||
-- Not mutable | ||
type Not_Mut_Base is interface; | ||
procedure Test_Not_Mut (I : Not_Mut_Base; NM : out Not_Mutable) is abstract; | ||
|
||
-- Constrained | ||
type Constrained_Base is interface; | ||
procedure Test_Constrained (I : Constrained_Base; Const : out Constrained_Rec) is abstract; | ||
|
||
-- Constrained derived | ||
type Derived_Constrained_Base is interface; | ||
procedure Test_Derived_Constrained (I : Derived_Constrained_Base; Const : out Derived_Constrained_Rec) is abstract; | ||
end Tests; | ||
|
||
end Main; |
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,2 @@ | ||
project Prj is | ||
end Prj; |
Empty file.
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,3 @@ | ||
driver: checker | ||
rule_name: KP_19142 | ||
project: prj.gpr |