Skip to content

Commit

Permalink
Merge branch 'topic/fix_exception_propagation_from_callbacks' into 'm…
Browse files Browse the repository at this point in the history
…aster'

Fix exception_propagation_from_callbacks

Closes #166

See merge request eng/libadalang/langkit-query-language!130
  • Loading branch information
raph-amiard committed Oct 31, 2023
2 parents f794335 + 7e740b1 commit 7500bb2
Show file tree
Hide file tree
Showing 5 changed files with 88 additions and 24 deletions.
20 changes: 10 additions & 10 deletions lkql_checker/doc/gnatcheck_rm/predefined_rules.rst
Original file line number Diff line number Diff line change
Expand Up @@ -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:
Expand Down Expand Up @@ -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

Expand Down
26 changes: 22 additions & 4 deletions lkql_checker/share/lkql/exception_propagation_from_callbacks.lkql
Original file line number Diff line number Diff line change
Expand Up @@ -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")
Expand All @@ -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()
Expand Down
33 changes: 30 additions & 3 deletions testsuite/tests/checks/exception_propagation_from_callbacks/p.adb
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
Original file line number Diff line number Diff line change
Expand Up @@ -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
| ^^^^^^^^^^

Original file line number Diff line number Diff line change
Expand Up @@ -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")
]

0 comments on commit 7500bb2

Please sign in to comment.