Merge branch 'topic/kp_19142' into 'master'

Add a detector for KP 19142

Closes #237

See merge request eng/libadalang/langkit-query-language!191

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)])

lkql_checker/share/lkql/stdlib.lkql

@@ -25,7 +25,7 @@ fun all(iterable) =
 
 fun any(iterable) =
     |" Return whether at least one element in the given iterable is truthy
-    [x for x in iterable if x].length > 0
+    [x for x in iterable if x]?[1] != ()
 
 fun is_assert_pragma(s) =
     |" Return ``true`` if the string ``s`` is the name of an assert pragma

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;

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;

testsuite/tests/checks/KP-19142/prj.gpr

@@ -0,0 +1,2 @@
+project Prj is
+end Prj;

testsuite/tests/checks/KP-19142/test.yaml

@@ -0,0 +1,3 @@
+driver: checker
+rule_name: KP_19142
+project: prj.gpr