Add detector for KP-19749

Author: HugoGGuerrier

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

@@ -0,0 +1,12 @@
+import stdlib
+
+@check(help="possible occurrence of KP 19749",
+       message="possible occurrence of KP 19749")
+fun kp_19749(node) =
+    |" Flag "Task_Dispatching_Policy", "Locking_Policy" and "Queuing_Policy"
+    |" in units that don't contain any explicit tasking construct.
+    node is PragmaNode
+    when match node.f_id.text.to_lower_case
+    | ("task_dispatching_policy" | "locking_policy" | "queuing_policy") =>
+        (from node.unit.root select first n@AdaNode when stdlib.is_tasking_construct(n)) is null
+    | * => false

lkql_checker/share/lkql/kp/kp.json

@@ -23,6 +23,7 @@
         "kp_19625": "24.*",
         "kp_19696": "24.*,25.1",
         "kp_19747": "24.*",
+        "kp_19749": "24.*,25.*",
         "kp_19753": "21.*,22.*,23.*,24.*,25.*",
         "kp_ob03_009": "19.*",
         "kp_p226_024": "7.1.*,7.2.*,7.3.*,7.4.1,7.4.2,7.4.3",

lkql_checker/share/lkql/stdlib.lkql

@@ -695,6 +695,37 @@ fun depends_on_mutable_discriminant(component_decl) =
                    for v in from component_decl through parent select VariantPart].to_list
     ])
 
+fun is_tasking_construct(node) =
+    |" Returns whether the given node is a construct related to Ada tasking,
+    |" in other words: All constructs described in the section 9 of Ada RM.
+    node is (
+        TaskTypeDecl
+        | TaskBody
+        | SingleTaskDecl
+        | SingleTaskTypeDecl
+        | ProtectedTypeDecl
+        | ProtectedBody
+        | SingleProtectedDecl
+        | AcceptStmt
+        | AcceptStmtBody
+        | RequeueStmt
+        | SelectStmt
+        | DelayStmt
+        | AbortStmt
+        | ObjectDecl(
+            p_type_expression: TypeExpr(
+                p_designated_type_decl(): (ProtectedTypeDecl | TaskTypeDecl)
+            )
+        )
+        | Name(
+            p_is_call: true,
+            p_referenced_decl: d@BasicDecl when ultimate_subprogram_alias(d) is (
+                EntryDecl
+                | BasicSubpDecl(any parent: (ProtectedTypeDecl | ProtectedBody | SingleProtectedDecl))
+            )
+        )
+    )
+
 selector component_types
     |" Return all the ``BaseTypeDecl`` corresponding to all fields of a given
     |" type, including their full views, base types and subtypes.

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

@@ -0,0 +1,3 @@
+project Prj is
+   for Source_Dirs use ("src");
+end Prj;

testsuite/tests/checks/KP-19749/src/abort_stmt.adb

@@ -0,0 +1,8 @@
+pragma Task_Dispatching_Policy (FIFO_Within_Priorities);   --  NOFLAG
+
+with Task_Type; use Task_Type;
+
+procedure Abort_Stmt is
+begin
+   abort T_Obj;
+end Abort_Stmt;

testsuite/tests/checks/KP-19749/src/delay_stmt.adb

@@ -0,0 +1,6 @@
+pragma Task_Dispatching_Policy (FIFO_Within_Priorities);   --  NOFLAG
+
+procedure Delay_Stmt is
+begin
+   delay Duration (0);
+end Delay_Stmt;

testsuite/tests/checks/KP-19749/src/flags.adb

@@ -0,0 +1,12 @@
+pragma Task_Dispatching_Policy (FIFO_Within_Priorities);   --  FLAG
+pragma Locking_Policy (Ceiling_Locking);                   --  FLAG
+pragma Queuing_Policy (FIFO_Queuing);                      --  FLAG
+pragma Discard_Names;                                      --  NOFLAG
+
+with Task_Type;      use Task_Type;
+with Protected_Type; use Protected_Type;
+
+procedure Flags is
+begin
+   null;
+end Flags;

testsuite/tests/checks/KP-19749/src/protected_obj_decl.adb

@@ -0,0 +1,9 @@
+pragma Task_Dispatching_Policy (FIFO_Within_Priorities);   --  NOFLAG
+
+with Protected_Type; use Protected_Type;
+
+procedure Protected_Obj_Decl is
+   O : P;
+begin
+   null;
+end Protected_Obj_Decl;

testsuite/tests/checks/KP-19749/src/protected_subp_call.adb

@@ -0,0 +1,8 @@
+pragma Task_Dispatching_Policy (FIFO_Within_Priorities);   --  NOFLAG
+
+with Protected_Type; use Protected_Type;
+
+procedure Protected_Subp_Call is
+begin
+   P_Obj.Proc;
+end Protected_Subp_Call;

testsuite/tests/checks/KP-19749/src/protected_type.adb

@@ -0,0 +1,10 @@
+pragma Task_Dispatching_Policy (FIFO_Within_Priorities);   --  NOFLAG
+
+package body Protected_Type is
+   protected body P is
+      procedure Proc is
+      begin
+         null;
+      end Proc;
+   end P;
+end Protected_Type;