Merge branch 'dev/kp-18718' into 'master'

Add KP detector for eng/toolchain/gnat#449

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

lkql_checker/share/lkql/kp/KP-18718.lkql

@@ -0,0 +1,36 @@
+# Flag object declarations initialized via a call to a function being
+# either an expression function or consisting of a single return statement,
+# returning a discriminated record type with default discriminants and a
+# variant part
+
+@check(help="possible occurrence of KP 18718",
+       message="possible occurrence of KP 18718 if compiled with optimization",
+       impact="23.*")
+fun kp_18718(node) =
+    node is ObjectDecl(
+        # An ObjectDecl with a default expression being a function call
+        f_default_expr is c@Name(p_is_call() is true)
+        when {
+            # Retrieve the function body for the call
+            val b = match c.p_referenced_decl()
+                    | decl@BaseSubpBody => decl
+                    | decl@SubpDecl     => decl.p_body_part()
+                    | *                 => null;
+
+            # An expression function or a function with a single return
+            (b is ExprFunction or
+                  SubpBody when b.f_stmts.f_stmts.children_count == 1
+                            and b.f_stmts.f_stmts[1] is ReturnStmt or
+                                                        ExtendedReturnStmt) and
+            # Retrieve the return type
+            b.f_subp_spec.p_return_type() is t@BaseTypeDecl
+               when t.p_canonical_type().p_full_view() is type@TypeDecl
+            # Return type has discriminants
+               when type.f_discriminants is KnownDiscriminantPart
+            # with default values
+                and [d for d in type.f_discriminants.f_discr_specs.children
+                                if d.f_default_expr != null]
+            # and a variant part
+                and type.f_type_def.f_record_def.f_components.
+                    f_variant_part is VariantPart
+        })

testsuite/tests/checks/KP-18718/p.adb

@@ -0,0 +1,21 @@
+package body P is
+
+   function Work return Discr is
+     (Discr'(Content    => Yellow,
+             Data       => 1));
+
+   function Work (X : Integer) return Discr is
+   begin
+      return D : Discr do
+         null;
+      end return;
+   end;
+
+   function Work return Integer is
+      D  : constant Discr := Work;      --  FLAG
+      D2 : constant Discr := Work (1);  --  FLAG
+   begin
+      return 0;
+   end Work;
+
+end P;

testsuite/tests/checks/KP-18718/p.ads

@@ -0,0 +1,16 @@
+package P is
+   type Enum is (Blue, Yellow);
+   type Base (Content : Enum := Blue) is record
+      case Content is
+         when Blue =>
+            null;
+         when Yellow =>
+            Data : Integer;
+      end case;
+   end record;
+   subtype Discr is Base;
+
+   function Work return Discr;
+   function Work return Integer with Inline;
+
+end P;

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

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

testsuite/tests/checks/KP-18718/test.out

@@ -0,0 +1,8 @@
+p.adb:15:7: rule violation: possible occurrence of KP 18718 if compiled with optimization
+15 |       D  : constant Discr := Work;      --  FLAG
+   |       ^
+
+p.adb:16:7: rule violation: possible occurrence of KP 18718 if compiled with optimization
+16 |       D2 : constant Discr := Work (1);  --  FLAG
+   |       ^^
+

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

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