diff --git a/ada/ast.py b/ada/ast.py index 86856eb8f..a9a5e98d3 100644 --- a/ada/ast.py +++ b/ada/ast.py @@ -531,6 +531,16 @@ def semantic_parent(): """ return Entity.semantic_parent_helper(Entity.node_env) + @langkit_property(return_type=T.AdaNode.entity.array) + def semantic_parents(): + """ + Recursively call ``semantic_parent`` to get all the semantic parents + of this node. + """ + return Entity.semantic_parent.then( + lambda sp: sp.singleton.concat(sp.semantic_parents) + ) + @langkit_property(public=True, return_type=T.BasicDecl.entity) def parent_basic_decl(): """ @@ -3747,8 +3757,20 @@ def in_scope(): """ return And( Not(origin.is_null), - origin.unit == Self.unit, - Not(origin.parents.find(lambda p: p == Self).is_null) + Or( + # Either origin and Self are in the same unit + And( + origin.unit == Self.unit, + Not(origin.parents.find(lambda p: p == Self).is_null) + ), + # Either origin is nested in a subprogam subunit of Self + origin.enclosing_compilation_unit.body.cast(T.Subunit).then( + lambda su: su.bodies_root.any( + lambda br: br.is_a(T.BaseSubpBody) + & (br.unit == Self.unit) + ) + ) + ) ) @langkit_property() @@ -18081,7 +18103,7 @@ def env_elements_baseid(): # local variables. If( is_prefix, - Entity.parents.find( + Entity.semantic_parents.find( lambda n: n.is_a(T.TaskBody, T.BaseSubpBody).then( lambda _: n.cast(T.BasicDecl).defining_name @@ -22576,6 +22598,27 @@ def body_root(): """ return Self.root_unit.decl.as_bare_entity + @langkit_property(return_type=T.BasicDecl.entity.array) + def bodies_root(): + """ + Return all the bodies this subunit is rooted in, so that for: + + .. code::ada + + separate (P1.P2.P3) + procedure P4 is ... + + ``bodies_root`` will return ``[P3, P2, P1]``, an array containing all + the nested subunits (``P2``, ``P3``), as well as the body root ``P1``, + in which ``P4`` has been recursively rooted in. + """ + br = Var(Self.root_unit.decl.as_bare_entity) + + return br.parent.cast(T.Subunit).then( + lambda su: br.singleton.concat(su.bodies_root), + default_val=br.singleton + ) + @langkit_property( return_type=T.BodyStub, # At the time of its introduction, this property was used only by diff --git a/testsuite/tests/name_resolution/recursive_subunit/p1-p2-p3-p4.adb b/testsuite/tests/name_resolution/recursive_subunit/p1-p2-p3-p4.adb new file mode 100644 index 000000000..049d94935 --- /dev/null +++ b/testsuite/tests/name_resolution/recursive_subunit/p1-p2-p3-p4.adb @@ -0,0 +1,21 @@ +separate (P1.P2.P3) +procedure P4 is + S : String (1 .. 2); + C : Character; +begin + S := P2.S; + pragma Test_Statement; + + C := P1.C; + pragma Test_Statement; + + C := P2.H; + pragma Test_Statement; + + S := P3.S; + pragma Test_Statement; + + C := P3.C; + pragma Test_Statement; + +end P4; diff --git a/testsuite/tests/name_resolution/recursive_subunit/p1-p2-p3.adb b/testsuite/tests/name_resolution/recursive_subunit/p1-p2-p3.adb new file mode 100644 index 000000000..1b64a8704 --- /dev/null +++ b/testsuite/tests/name_resolution/recursive_subunit/p1-p2-p3.adb @@ -0,0 +1,15 @@ +separate (P1.P2) +procedure P3 is + S : String (1 .. 2); + C : Character; + procedure P4 is separate; +begin + S := P2.S; + pragma Test_Statement; + + C := P1.C; + pragma Test_Statement; + + C := P2.H; + pragma Test_Statement; +end P3; diff --git a/testsuite/tests/name_resolution/recursive_subunit/p1-p2.adb b/testsuite/tests/name_resolution/recursive_subunit/p1-p2.adb new file mode 100644 index 000000000..70aeef55d --- /dev/null +++ b/testsuite/tests/name_resolution/recursive_subunit/p1-p2.adb @@ -0,0 +1,12 @@ +separate (P1) +procedure P2 (H : Character) is + S : String (1 .. 2); + C : Character; + procedure P3 is separate; +begin + C := P1.C; + pragma Test_Statement; + + S := P1.C & "-"; + pragma Test_Statement; +end P2; diff --git a/testsuite/tests/name_resolution/recursive_subunit/p1.adb b/testsuite/tests/name_resolution/recursive_subunit/p1.adb new file mode 100644 index 000000000..5bf20e1e2 --- /dev/null +++ b/testsuite/tests/name_resolution/recursive_subunit/p1.adb @@ -0,0 +1,6 @@ +procedure P1 is + C : constant Character := '1'; + procedure P2 (H : Character) is separate; +begin + null; +end P1; diff --git a/testsuite/tests/name_resolution/recursive_subunit/test.out b/testsuite/tests/name_resolution/recursive_subunit/test.out new file mode 100644 index 000000000..5228986fa --- /dev/null +++ b/testsuite/tests/name_resolution/recursive_subunit/test.out @@ -0,0 +1,227 @@ +Analyzing p1-p2.adb +################### + +Resolving xrefs for node +******************************************************** + +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: None + expected type: None +Expr: + references: + type: + expected type: + +Resolving xrefs for node +********************************************************** + +Expr: + references: + type: + expected type: None +Expr: + type: + expected type: +Expr: + references: + type: + expected type: +Expr: + references: + type: None + expected type: None +Expr: + references: + type: + expected type: +Expr: + type: + expected type: +Expr: + references: None + type: None + expected type: None +Expr: + references: None + type: + expected type: + + +Analyzing p1-p2-p3.adb +###################### + +Resolving xrefs for node +*********************************************************** + +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: None + expected type: None +Expr: + references: + type: + expected type: + +Resolving xrefs for node +************************************************************* + +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: None + expected type: None +Expr: + references: + type: + expected type: + +Resolving xrefs for node +************************************************************* + +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: None + expected type: None +Expr: + references: + type: + expected type: + + +Analyzing p1-p2-p3-p4.adb +######################### + +Resolving xrefs for node +************************************************************** + +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: None + expected type: None +Expr: + references: + type: + expected type: + +Resolving xrefs for node +************************************************************** + +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: None + expected type: None +Expr: + references: + type: + expected type: + +Resolving xrefs for node +**************************************************************** + +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: None + expected type: None +Expr: + references: + type: + expected type: + +Resolving xrefs for node +**************************************************************** + +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: None + expected type: None +Expr: + references: + type: + expected type: + +Resolving xrefs for node +**************************************************************** + +Expr: + references: + type: + expected type: None +Expr: + references: + type: + expected type: +Expr: + references: + type: None + expected type: None +Expr: + references: + type: + expected type: + + +Done. diff --git a/testsuite/tests/name_resolution/recursive_subunit/test.yaml b/testsuite/tests/name_resolution/recursive_subunit/test.yaml new file mode 100644 index 000000000..e7e229217 --- /dev/null +++ b/testsuite/tests/name_resolution/recursive_subunit/test.yaml @@ -0,0 +1,2 @@ +driver: name-resolution +input_sources: [p1-p2.adb, p1-p2-p3.adb, p1-p2-p3-p4.adb]