diff --git a/ada/ast.py b/ada/ast.py index b4a0880c3..b7adadb2a 100644 --- a/ada/ast.py +++ b/ada/ast.py @@ -18080,9 +18080,10 @@ def env_elements_baseid(): ) ), - # This identifier is the name for a called subprogram or an array. + # This identifier is the name for a called subprogram, entry, or an + # array. # So only keep: - # * subprograms for which the actuals match + # * subprograms/entries for which the actuals match # * arrays for which the number of dimensions match # * any type that has a user defined indexing aspect. @@ -18093,35 +18094,9 @@ def env_elements_baseid(): lambda b=BasicDecl: b.subp_spec_or_null.then( - lambda spec: Let( - lambda real_pc=If( - spec.cast(T.EntrySpec)._.family_type.is_null, - pc, pc.parent.cast(T.CallExpr) - ): - # ``real_pc`` can be null if we are handling a - # paramless entry decl that has an entry family, - # in which case the subsequent checks are not - # relevant. - real_pc.is_null - - # Either the subprogram is matching the CallExpr's - # parameters. - | And( - spec.is_matching_param_list( - params, b.info.md.dottable_subp - ), - real_pc.parent.cast(T.CallExpr).then( - lambda ce: ce.check_for_type(b.expr_type), - default_val=True - ) - ) - - # Or the entity is parameterless, and the returned - # component (s) matches the callexpr (s). - | And(real_pc.check_for_type(b.expr_type), - spec.paramless(b.info.md.dottable_subp)), + lambda spec: + Entity.call_matches_spec(spec, pc, params, b), - ), # In the case of ObjectDecls/CompDecls in general, # verify that the callexpr is valid for the given # type designator. @@ -18137,6 +18112,56 @@ def env_elements_baseid(): ) )) + @langkit_property(dynamic_vars=[env, origin], return_type=T.Bool) + def call_matches_spec(spec=T.BaseSubpSpec.entity, pc=T.CallExpr.entity, + params=T.AssocList.entity, b=T.BasicDecl.entity): + """ + Return whether the BasicDecl ``b`` should be kept during + ``env_elements_baseid`` items filtering. This piece of code has been + extracted from ``env_elements_baseid`` to improve code readability. + """ + family_type = Var(spec.cast(T.EntrySpec)._.family_type) + + # If b is a `EntryDecl` with a specified family type, then the real + # `CallExpr` is its parent, as in: `Task.Entry (Family) (Arg1, Arg2)`, + # where `Entry (Family) (Arg1, Arg2)` is the real `CallExpr`, not just + # `Entry (Family)`. Adjust `pc` and `params` accordingly: + real_pc = Var(If( + family_type.is_null, + pc, pc.parent.cast(T.CallExpr) + )) + real_params = Var(If( + family_type.is_null, + params, pc.parent.cast(T.CallExpr).then( + lambda ce: + ce.suffix.cast_or_raise(AssocList) + ) + )) + + return ( + # ``real_pc`` can be null if we are handling a paramless entry decl + # that has an entry family, in which case the subsequent checks are + # not relevant. + real_pc.is_null + + # Either the subprogram/entry is matching the CallExpr's parameters + | And( + spec.is_matching_param_list( + real_params, b.info.md.dottable_subp + ), + real_pc.parent.cast(T.CallExpr).then( + lambda ce: + ce.check_for_type(b.expr_type), + default_val=True + ) + ) + + # Or the entity is parameterless, and the returned component (s) + # matches the callexpr (s). + | And(real_pc.check_for_type(b.expr_type), + spec.paramless(b.info.md.dottable_subp)) + ) + @langkit_property(return_type=Bool) def denotes_the_property_function(subp_spec=T.BaseSubpSpec.entity): # Return true whether this node can refer to a property function diff --git a/testsuite/tests/name_resolution/entry_families_3/test.adb b/testsuite/tests/name_resolution/entry_families_3/test.adb new file mode 100644 index 000000000..780b4fbb2 --- /dev/null +++ b/testsuite/tests/name_resolution/entry_families_3/test.adb @@ -0,0 +1,38 @@ +procedure Test is + + type Enume is (S, P, A, R, K); + + task type TT is + entry F (1 .. 3) (I : Integer; J : out Integer); + entry G (Enume) (I : Integer; J : out Integer); + end TT; + + type Parent is access TT; + type T is new Parent; + + X : T; + I : Integer := 0; + J : Integer := 0; + + task body TT is + N : Integer := 1; + begin + loop + select + accept F (2) (I : Integer; J : out Integer) do + j := i + n; + end F; + or + terminate; + end select; + end loop; + end TT; +begin + X := new TT; + + X.F (2) (I, J); + pragma Test_Statement; + + X.G (R) (I, J); + pragma Test_Statement; +end Test; diff --git a/testsuite/tests/name_resolution/entry_families_3/test.out b/testsuite/tests/name_resolution/entry_families_3/test.out new file mode 100644 index 000000000..9a9076bbe --- /dev/null +++ b/testsuite/tests/name_resolution/entry_families_3/test.out @@ -0,0 +1,77 @@ +Analyzing test.adb +################## + +Resolving xrefs for node +******************************************************* + +Expr: + references: + type: None + expected type: None +Expr: + references: + type: None + expected type: None +Expr: + references: + type: None + expected type: None +Expr: + references: + type: + expected type: None +Expr: + references: + type: None + expected type: None +Expr: + references: None + type: + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: + +Resolving xrefs for node +******************************************************* + +Expr: + references: + type: None + expected type: None +Expr: + references: + type: None + expected type: None +Expr: + references: + type: None + expected type: None +Expr: + references: + type: + expected type: None +Expr: + references: + type: None + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: +Expr: + references: + type: + expected type: + + +Done. diff --git a/testsuite/tests/name_resolution/entry_families_3/test.yaml b/testsuite/tests/name_resolution/entry_families_3/test.yaml new file mode 100644 index 000000000..173e325ff --- /dev/null +++ b/testsuite/tests/name_resolution/entry_families_3/test.yaml @@ -0,0 +1,2 @@ +driver: name-resolution +input_sources: [test.adb]