Fix exception_propagation_from_callbacks

Author: raph-amiard

lkql_checker/doc/gnatcheck_rm/predefined_rules.rst

@@ -2359,24 +2359,19 @@ This rule has no parameters.
 
 Flag an ``'Address`` or ``'Access`` attribute if:
 
-*
-  this attribute is a reference to a subprogram;
+* this attribute is a reference to a subprogram;
 
-*
-  this subprogram may propagate an exception;
+* this subprogram may propagate an exception;
 
-*
-  this attribute is an actual parameter of a subprogram call, and both the
+* this attribute is an actual parameter of a subprogram call, and both the
   subprogram called and the corresponding formal parameter are specified by a
   rule parameter.
 
 A subprogram is considered as not propagating an exception if:
 
-*
-  its body has an exception handler with ``others`` exception choice;
+* its body has an exception handler with ``others`` exception choice;
 
-*
-  no exception handler in the body contains a raise statement nor a call to
+* no exception handler in the body contains a raise statement nor a call to
   ``Ada.Exception.Raise_Exception`` or ``Ada.Exception.Reraise_Occurrence``.
 
 The rule has an optional parameter for the ``+R`` option:
@@ -2413,6 +2408,11 @@ the subprogram of interest in case if renamings are used for this subprogram.
 Note also, that the rule does not make any overload resolution, so calls to
 all the subprograms corresponding to ``subprogram_name`` are checked.
 
+.. note:: Note that you can use both fully qualified names to
+   instantiated or non-instantiated generic subprograms, depending on the
+   granularity you wish for. However **you cannot use a mix of the two**, so
+   the names need to be either fully instantiated or fully uninstantiated.
+
 
 .. rubric:: Example
 

lkql_checker/share/lkql/exception_propagation_from_callbacks.lkql

@@ -13,6 +13,16 @@
 
 import stdlib
 
+fun get_uninstantiated_subp(subp) =
+   |" Works around an inconsistency in LAL's API wrt. generic subprograms
+   |" TODO: Fix when eng/libadalang/libadalang/-/issues/1127 is fixed
+    match subp
+    | GenericSubpInstantiation(f_generic_subp_name is s@*) =>
+        s.p_referenced_decl().p_get_uninstantiated_node()
+    | AdaNode => subp.p_get_uninstantiated_node()
+    | * => null
+
+
 @check(help="callback may propagate exceptions (global analysis required)",
        message="callback may propagate exceptions",
        category="Style", subcategory="Programming Practice")
@@ -26,10 +36,18 @@ fun exception_propagation_from_callbacks(node, callbacks=[]) =
      when (from node through parent
            select first CallExpr(p_is_call() is true)) is call@CallExpr
       when {
-          val n = call.f_name.p_referenced_decl()?.
-                  p_canonical_fully_qualified_name?();
-          val name = if n == () then "" else n;
-          val params = [c[2] for c in callbacks if c[1] == name].to_list;
+          val uninst_subp_name = get_uninstantiated_subp(
+              call.f_name.p_referenced_decl()
+          )?.p_canonical_fully_qualified_name?();
+
+          val subp_name = call.f_name.p_referenced_decl()
+                              ?.p_canonical_fully_qualified_name?();
+
+          val params = [
+              c[2] for c in callbacks
+              if c[1] == uninst_subp_name
+                 or c[1] == subp_name
+          ].to_list;
 
           params.length != 0 and
           [p for p in call.p_call_params()

testsuite/tests/checks/exception_propagation_from_callbacks/p.adb

@@ -37,13 +37,40 @@ package body P is
    procedure P3 is new P3_G;
 
    generic procedure Take_Cb_G (I : Integer; Param : access procedure);
-   procedure Take_Cb_G (I : Integer; Param : access procedure) is null;
+   generic procedure Take_Cb_G_2 (I : Integer; Param : access procedure);
+
+   generic package Gen_Pkg is
+      procedure Take_Cb (I : Integer; Param : access procedure);
+   end Gen_Pkg;
+
+   package Pkg_Inst is new Gen_Pkg;
+
    procedure Take_Cb_I is new Take_Cb_G;
+   procedure Take_Cb_I_2 is new Take_Cb_G_2;
+
+   generic package Gen_Pkg_2 is
+      generic procedure Gen_Cb (I : Integer; Param : access procedure);
+   end Gen_Pkg_2;
+
+   package Pkg_2_Inst is new Gen_Pkg_2;
+
+   procedure Cb_Inst is new Pkg_2_Inst.Gen_Cb;
 
    procedure Calls2 is
    begin
-      Take_Cb (1, P3'Access);        --  FLAG
-      Take_Cb_I (1, P1'Access);      --  FLAG
+      Take_Cb (1, P3'Access);           --  FLAG
+
+      --  Check that we can flag a generic subp via its instantiated name
+      Take_Cb_I (1, P1'Access);         --  FLAG
+
+      --  Check that we can flag a generic subp via its uninstantiated name
+      Take_Cb_I_2 (1, P1'Access);       --  FLAG
+
+      --  Check that we can flag a subp in a generic pkg via its uninstantiated
+      --  name
+      Pkg_Inst.Take_Cb (1, P1'Access);  --  FLAG
+
+      Cb_Inst (1, P1'Access);           -- FLAG
    end Calls2;
 
    --  Tests on subunits

testsuite/tests/checks/exception_propagation_from_callbacks/test.out

@@ -2,15 +2,27 @@ p.adb:22:25: rule violation: callback may propagate exceptions
 22 |       Take_Cb (Param => P1'Access, I => 1);   --  FLAG
    |                         ^^^^^^^^^
 
-p.adb:45:19: rule violation: callback may propagate exceptions
-45 |       Take_Cb (1, P3'Access);        --  FLAG
+p.adb:61:19: rule violation: callback may propagate exceptions
+61 |       Take_Cb (1, P3'Access);           --  FLAG
    |                   ^^^^^^^^^
 
-p.adb:46:21: rule violation: callback may propagate exceptions
-46 |       Take_Cb_I (1, P1'Access);      --  FLAG
+p.adb:64:21: rule violation: callback may propagate exceptions
+64 |       Take_Cb_I (1, P1'Access);         --  FLAG
    |                     ^^^^^^^^^
 
-p.adb:55:19: rule violation: callback may propagate exceptions
-55 |       Take_Cb (1, Sep'Access);      --  FLAG
+p.adb:67:23: rule violation: callback may propagate exceptions
+67 |       Take_Cb_I_2 (1, P1'Access);       --  FLAG
+   |                       ^^^^^^^^^
+
+p.adb:71:28: rule violation: callback may propagate exceptions
+71 |       Pkg_Inst.Take_Cb (1, P1'Access);  --  FLAG
+   |                            ^^^^^^^^^
+
+p.adb:73:19: rule violation: callback may propagate exceptions
+73 |       Cb_Inst (1, P1'Access);           -- FLAG
+   |                   ^^^^^^^^^
+
+p.adb:82:19: rule violation: callback may propagate exceptions
+82 |       Take_Cb (1, Sep'Access);      --  FLAG
    |                   ^^^^^^^^^^
 

testsuite/tests/checks/exception_propagation_from_callbacks/test.yaml

@@ -2,4 +2,11 @@ driver: 'checker'
 rule_name: Exception_Propagation_From_Callbacks
 project: 'prj.gpr'
 rule_arguments:
-   exception_propagation_from_callbacks.callbacks: '[("p.take_cb", "Param"),("p.take_cb_i", "Param")]'
+   exception_propagation_from_callbacks.callbacks: |
+       [
+           ("p.take_cb", "Param"),
+           ("p.take_cb_i", "Param"),
+           ("p.take_cb_g_2", "Param"),
+           ("p.gen_pkg.take_cb", "Param"),
+           ("p.gen_pkg_2.gen_cb", "Param")
+       ]