From 20546bed2a784b066e44e003f8d094e756fe6a84 Mon Sep 17 00:00:00 2001 From: Hugo Guerrier Date: Tue, 26 Mar 2024 17:17:25 +0100 Subject: [PATCH] Add KP detector for KP-19142 --- lkql_checker/share/lkql/kp/KP-19142.lkql | 49 +++++++++++ testsuite/tests/checks/KP-19142/main.adb | 101 ++++++++++++++++++++++ testsuite/tests/checks/KP-19142/main.ads | 84 ++++++++++++++++++ testsuite/tests/checks/KP-19142/prj.gpr | 2 + testsuite/tests/checks/KP-19142/test.out | 0 testsuite/tests/checks/KP-19142/test.yaml | 3 + 6 files changed, 239 insertions(+) create mode 100644 lkql_checker/share/lkql/kp/KP-19142.lkql create mode 100644 testsuite/tests/checks/KP-19142/main.adb create mode 100644 testsuite/tests/checks/KP-19142/main.ads create mode 100644 testsuite/tests/checks/KP-19142/prj.gpr create mode 100644 testsuite/tests/checks/KP-19142/test.out create mode 100644 testsuite/tests/checks/KP-19142/test.yaml diff --git a/lkql_checker/share/lkql/kp/KP-19142.lkql b/lkql_checker/share/lkql/kp/KP-19142.lkql new file mode 100644 index 000000000..e1bcdc72f --- /dev/null +++ b/lkql_checker/share/lkql/kp/KP-19142.lkql @@ -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)]) diff --git a/testsuite/tests/checks/KP-19142/main.adb b/testsuite/tests/checks/KP-19142/main.adb new file mode 100644 index 000000000..81f3759d4 --- /dev/null +++ b/testsuite/tests/checks/KP-19142/main.adb @@ -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; diff --git a/testsuite/tests/checks/KP-19142/main.ads b/testsuite/tests/checks/KP-19142/main.ads new file mode 100644 index 000000000..fcc8f1a26 --- /dev/null +++ b/testsuite/tests/checks/KP-19142/main.ads @@ -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; diff --git a/testsuite/tests/checks/KP-19142/prj.gpr b/testsuite/tests/checks/KP-19142/prj.gpr new file mode 100644 index 000000000..3abfff4af --- /dev/null +++ b/testsuite/tests/checks/KP-19142/prj.gpr @@ -0,0 +1,2 @@ +project Prj is +end Prj; diff --git a/testsuite/tests/checks/KP-19142/test.out b/testsuite/tests/checks/KP-19142/test.out new file mode 100644 index 000000000..e69de29bb diff --git a/testsuite/tests/checks/KP-19142/test.yaml b/testsuite/tests/checks/KP-19142/test.yaml new file mode 100644 index 000000000..5b0cf4119 --- /dev/null +++ b/testsuite/tests/checks/KP-19142/test.yaml @@ -0,0 +1,3 @@ +driver: checker +rule_name: KP_19142 +project: prj.gpr