diff --git a/lkql_checker/doc/gnatcheck_rm/predefined_rules.rst b/lkql_checker/doc/gnatcheck_rm/predefined_rules.rst index 8315bab3e..54e760e97 100644 --- a/lkql_checker/doc/gnatcheck_rm/predefined_rules.rst +++ b/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 diff --git a/lkql_checker/share/lkql/exception_propagation_from_callbacks.lkql b/lkql_checker/share/lkql/exception_propagation_from_callbacks.lkql index 00f2fb7fe..0b9592054 100644 --- a/lkql_checker/share/lkql/exception_propagation_from_callbacks.lkql +++ b/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() diff --git a/testsuite/tests/checks/exception_propagation_from_callbacks/p.adb b/testsuite/tests/checks/exception_propagation_from_callbacks/p.adb index 2c5c8cd55..3fa4759d6 100644 --- a/testsuite/tests/checks/exception_propagation_from_callbacks/p.adb +++ b/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 diff --git a/testsuite/tests/checks/exception_propagation_from_callbacks/test.out b/testsuite/tests/checks/exception_propagation_from_callbacks/test.out index 7425dd5af..9e613fb66 100644 --- a/testsuite/tests/checks/exception_propagation_from_callbacks/test.out +++ b/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 | ^^^^^^^^^^ diff --git a/testsuite/tests/checks/exception_propagation_from_callbacks/test.yaml b/testsuite/tests/checks/exception_propagation_from_callbacks/test.yaml index 0e062d1c5..717e9f5d5 100644 --- a/testsuite/tests/checks/exception_propagation_from_callbacks/test.yaml +++ b/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") + ]