diff --git a/ada/nodes.lkt b/ada/nodes.lkt index 506392cf9..9126675c4 100644 --- a/ada/nodes.lkt +++ b/ada/nodes.lkt @@ -347,7 +347,8 @@ class AdaNode implements Node[AdaNode] { |" |" .. note:: If the parent BasicDecl of the given node is a generic |" declaration, this call will return the instantiation from which - |" the node was retrieved instead, if any. + |" the node was retrieved instead, if any. This also applies to bodies + |" of generic declarations. |" |" .. note:: When called on a subunit's body, this property will return |" its corresponding body stub. @@ -360,13 +361,24 @@ class AdaNode implements Node[AdaNode] { # call parent_basic_decl on the parent type, to avoid getting the # type itself as a parent_basic_decl (since some types introduce a # scope). - if self is ClasswideTypeDecl | DiscreteBaseSubtypeDecl | SynthAnonymousTypeDecl then self.semantic_parent().parent_basic_decl() else self.as[GenericDecl].do((gd) => gd.decl().get_instantiation()) or? self.semantic_parent().do( - (sp) => if sp is GenericDecl then sp.as[GenericDecl].do( - (gd) => gd.decl().get_instantiation() or? gd + if self is ClasswideTypeDecl + | DiscreteBaseSubtypeDecl + | SynthAnonymousTypeDecl then + self.semantic_parent().parent_basic_decl() + else { + val gen_decl = self.as[GenericDecl]; + val gen_body = self.as[Body]?.decl_part.do( + (dp) => dp.as[GenericDecl] or? dp.parent.as[GenericDecl] + ); + (gen_decl or? gen_body).do( + (gd) => gd.decl().get_instantiation() + ) or? self.semantic_parent().do((sp) => + if sp is GenericSubpInternal | GenericPackageInternal then + sp.parent_basic_decl() + else + sp.as[BasicDecl] or? sp.parent_basic_decl() ) - elif sp is GenericSubpInternal | GenericPackageInternal then sp.parent_basic_decl() - else sp.as[BasicDecl] or? sp.parent_basic_decl() - ) + } |" Helper for the properties ``has_spark_mode_on`` and |" ``is_subject_to_proof``. @@ -13426,22 +13438,25 @@ class DefiningName: Name { case n => n.as_single_tok_node_array().map((t) => t.text()) }; val bd = self.basic_decl(); - val self_name = def_name_array.map( - (t, i) => t & ( - if include_profile then bd.custom_id_text() else "" - ) & ( - if i == def_name_array.length() - 1 then suffix else "" - ) + val self_name = def_name_array.map((t, i) => + t + & (if include_profile then bd.custom_id_text() else "") + & (if i == def_name_array.length() - 1 then suffix else "") ); val parent_decl = bd.parent_basic_decl(); - val is_generic = bd is GenericDecl; - val is_instantiated = is_generic and parent_decl is GenericInstantiation; - val fqn = if not is_instantiated and bd.is_compilation_unit_root() then self_name else parent_decl?.fully_qualified_name_string_array(include_profile=include_profile).do( - (fqn) => # If we were on an instantiated generic declaration, we don't - # want to include the name of the generic but the name of the - # instance (which is `fqn`). - if is_instantiated then fqn else fqn & self_name - ); + val is_instantiated = (bd is GenericDecl | Body) + and parent_decl is GenericInstantiation; + val fqn = if not is_instantiated and bd.is_compilation_unit_root() then + self_name + else + parent_decl?.fully_qualified_name_string_array( + include_profile=include_profile + ).do((fqn) => + # If we were on an instantiated generic declaration, we don't + # want to include the name of the generic but the name of the + # instance (which is `fqn`). + if is_instantiated then fqn else fqn & self_name + ); bd.parent.as[Subunit].do( (su) => su.name.as_single_tok_node_array() diff --git a/testsuite/tests/properties/fully_qualified_name_8/test.adb b/testsuite/tests/properties/fully_qualified_name_8/test.adb new file mode 100644 index 000000000..3c87c7f71 --- /dev/null +++ b/testsuite/tests/properties/fully_qualified_name_8/test.adb @@ -0,0 +1,30 @@ +procedure Test is + generic + package Gen is + procedure Visible; + end Gen; + + package body Gen is + procedure Inner is + begin + null; + end Inner; + + procedure Visible is + begin + Inner; + end Visible; + + end Gen; + + package Inst is new Gen; + --% gen_body = node.p_designated_generic_decl.p_body_part + --% gen_body.p_fully_qualified_name + --% inner = gen_body.findall(lal.SubpBody)[0] + --% visible = gen_body.findall(lal.SubpBody)[1] + --% inner.p_fully_qualified_name + --% visible.p_fully_qualified_name +begin + Inst.Visible; +end Test; + diff --git a/testsuite/tests/properties/fully_qualified_name_8/test.out b/testsuite/tests/properties/fully_qualified_name_8/test.out new file mode 100644 index 000000000..a65199726 --- /dev/null +++ b/testsuite/tests/properties/fully_qualified_name_8/test.out @@ -0,0 +1,20 @@ +Working on node +========================================================================== + +Set 'gen_body' to 'node.p_designated_generic_decl.p_body_part' +Result: <| PackageBody ["Gen"] test.adb:7:4-18:12 [test.adb:20:4] |> + +Eval 'gen_body.p_fully_qualified_name' +Result: 'Test.Inst' + +Set 'inner' to 'gen_body.findall(lal.SubpBody)[0]' +Result: <| SubpBody ["Inner"] test.adb:8:7-11:17 [test.adb:20:4] |> + +Set 'visible' to 'gen_body.findall(lal.SubpBody)[1]' +Result: <| SubpBody ["Visible"] test.adb:13:7-16:19 [test.adb:20:4] |> + +Eval 'inner.p_fully_qualified_name' +Result: 'Test.Inst.Inner' + +Eval 'visible.p_fully_qualified_name' +Result: 'Test.Inst.Visible' diff --git a/testsuite/tests/properties/fully_qualified_name_8/test.yaml b/testsuite/tests/properties/fully_qualified_name_8/test.yaml new file mode 100644 index 000000000..35ad4d5c4 --- /dev/null +++ b/testsuite/tests/properties/fully_qualified_name_8/test.yaml @@ -0,0 +1,2 @@ +driver: inline-playground +input_sources: [test.adb] diff --git a/testsuite/tests/properties/parent_basic_decl/gen.adb b/testsuite/tests/properties/parent_basic_decl/gen.adb index 0d727c85b..30990a3c1 100644 --- a/testsuite/tests/properties/parent_basic_decl/gen.adb +++ b/testsuite/tests/properties/parent_basic_decl/gen.adb @@ -18,18 +18,18 @@ procedure Gen is --% decl = node.p_designated_generic_decl --% decl.p_parent_basic_decl --% internal = decl.f_package_decl - --% internal.p_parent_basic_decl + --% internal.p_parent_basic_decl.p_parent_basic_decl --% obj = internal.find(lal.ObjectDecl) - --% obj.p_parent_basic_decl + --% obj.p_parent_basic_decl.p_parent_basic_decl procedure My_Subp is new Subp_G; --% node.p_parent_basic_decl --% decl = node.p_designated_generic_decl --% decl.p_parent_basic_decl --% internal = decl.f_subp_decl - --% internal.p_parent_basic_decl + --% internal.p_parent_basic_decl.p_parent_basic_decl --% param = decl.find(lal.ParamSpec) - --% param.p_parent_basic_decl + --% param.p_parent_basic_decl.p_parent_basic_decl begin null; end Gen; diff --git a/testsuite/tests/properties/parent_basic_decl/test.out b/testsuite/tests/properties/parent_basic_decl/test.out index 86c27ec2b..7bd626bac 100644 --- a/testsuite/tests/properties/parent_basic_decl/test.out +++ b/testsuite/tests/properties/parent_basic_decl/test.out @@ -37,13 +37,13 @@ Result: Set 'internal' to 'decl.f_package_decl' Result: <| GenericPackageInternal ["Pkg_G"] gen.adb:3:4-5:14 [gen.adb:16:4] |> -Eval 'internal.p_parent_basic_decl' +Eval 'internal.p_parent_basic_decl.p_parent_basic_decl' Result: Set 'obj' to 'internal.find(lal.ObjectDecl)' Result: <| ObjectDecl ["X"] gen.adb:4:7-4:19 [gen.adb:16:4] |> -Eval 'obj.p_parent_basic_decl' +Eval 'obj.p_parent_basic_decl.p_parent_basic_decl' Result: Working on node @@ -61,13 +61,13 @@ Result: Set 'internal' to 'decl.f_subp_decl' Result: <| GenericSubpInternal ["Subp_G"] gen.adb:11:4-11:34 [gen.adb:25:4] |> -Eval 'internal.p_parent_basic_decl' +Eval 'internal.p_parent_basic_decl.p_parent_basic_decl' Result: Set 'param' to 'decl.find(lal.ParamSpec)' Result: <| ParamSpec ["X"] gen.adb:11:22-11:33 [gen.adb:25:4] |> -Eval 'param.p_parent_basic_decl' +Eval 'param.p_parent_basic_decl.p_parent_basic_decl' Result: Working on node diff --git a/testsuite/tests/properties/parent_basic_decl_2/main_package.ads b/testsuite/tests/properties/parent_basic_decl_2/main_package.ads index 70c15b635..b5a97e984 100644 --- a/testsuite/tests/properties/parent_basic_decl_2/main_package.ads +++ b/testsuite/tests/properties/parent_basic_decl_2/main_package.ads @@ -9,7 +9,7 @@ package Main_Package is procedure Operation_Not is new Operations.Operation (Boolean_And); --% decl=node.p_designated_generic_decl --% param=decl.p_subp_spec_or_null(True).p_params[0].p_defining_name - --% parent_decl=param.p_parent_basic_decl + --% parent_decl=param.p_parent_basic_decl.p_parent_basic_decl --% parent_decl.p_generic_instantiations end Main_Package; diff --git a/testsuite/tests/properties/parent_basic_decl_2/test.out b/testsuite/tests/properties/parent_basic_decl_2/test.out index a928e9c3c..963f4589f 100644 --- a/testsuite/tests/properties/parent_basic_decl_2/test.out +++ b/testsuite/tests/properties/parent_basic_decl_2/test.out @@ -7,7 +7,7 @@ Result: <| GenericSubpDecl ["Operation"] main_generic_package.ads:7:4-9:38 [main Set 'param' to 'decl.p_subp_spec_or_null(True).p_params[0].p_defining_name' Result: <| DefiningName "X" main_generic_package.ads:9:25-9:26 [main_package.ads:7:4, main_package.ads:9:4] |> -Set 'parent_decl' to 'param.p_parent_basic_decl' +Set 'parent_decl' to 'param.p_parent_basic_decl.p_parent_basic_decl' Result: Eval 'parent_decl.p_generic_instantiations' diff --git a/testsuite/tests/properties/parent_basic_decl_generic_body/test.adb b/testsuite/tests/properties/parent_basic_decl_generic_body/test.adb new file mode 100644 index 000000000..665f8ccb3 --- /dev/null +++ b/testsuite/tests/properties/parent_basic_decl_generic_body/test.adb @@ -0,0 +1,37 @@ +procedure Test is + generic + package Pkg is + procedure Foo; + --% node.p_parent_basic_decl + --% node.p_parent_basic_decl.p_parent_basic_decl + end Pkg; + + package body Pkg is + procedure Foo is null; + --% node.p_parent_basic_decl + --% node.p_parent_basic_decl.p_parent_basic_decl + end Pkg; + + package My_Pkg is new Pkg; + --% pkg_spec = node.p_designated_generic_decl + --% pkg_body = pkg_spec.p_body_part + --% pkg_spec.p_parent_basic_decl + --% pkg_body.p_parent_basic_decl + --% foo_spec = pkg_spec.find(lal.SubpDecl) + --% foo_spec.p_parent_basic_decl + --% foo_body = pkg_body.find(lal.NullSubpDecl) + --% foo_body.p_parent_basic_decl + + generic + procedure Bar; + + procedure Bar is null; + + procedure My_Bar is new Bar; + --% bar_decl = node.p_designated_generic_decl + --% bar_decl.p_parent_basic_decl + --% bar_body = bar_decl.p_body_part() + --% bar_body.p_parent_basic_decl +begin + null; +end Test; diff --git a/testsuite/tests/properties/parent_basic_decl_generic_body/test.out b/testsuite/tests/properties/parent_basic_decl_generic_body/test.out new file mode 100644 index 000000000..fff5e9778 --- /dev/null +++ b/testsuite/tests/properties/parent_basic_decl_generic_body/test.out @@ -0,0 +1,59 @@ +Working on node +==================================================== + +Eval 'node.p_parent_basic_decl' +Result: + +Eval 'node.p_parent_basic_decl.p_parent_basic_decl' +Result: + +Working on node +========================================================== + +Eval 'node.p_parent_basic_decl' +Result: + +Eval 'node.p_parent_basic_decl.p_parent_basic_decl' +Result: + +Working on node +============================================================================ + +Set 'pkg_spec' to 'node.p_designated_generic_decl' +Result: <| GenericPackageDecl ["Pkg"] test.adb:2:4-7:12 [test.adb:15:4] |> + +Set 'pkg_body' to 'pkg_spec.p_body_part' +Result: <| PackageBody ["Pkg"] test.adb:9:4-13:12 [test.adb:15:4] |> + +Eval 'pkg_spec.p_parent_basic_decl' +Result: + +Eval 'pkg_body.p_parent_basic_decl' +Result: + +Set 'foo_spec' to 'pkg_spec.find(lal.SubpDecl)' +Result: <| SubpDecl ["Foo"] test.adb:4:7-4:21 [test.adb:15:4] |> + +Eval 'foo_spec.p_parent_basic_decl' +Result: <| GenericPackageDecl ["Pkg"] test.adb:2:4-7:12 [test.adb:15:4] |> + +Set 'foo_body' to 'pkg_body.find(lal.NullSubpDecl)' +Result: <| NullSubpDecl ["Foo"] test.adb:10:7-10:29 [test.adb:15:4] |> + +Eval 'foo_body.p_parent_basic_decl' +Result: <| PackageBody ["Pkg"] test.adb:9:4-13:12 [test.adb:15:4] |> + +Working on node +========================================================================= + +Set 'bar_decl' to 'node.p_designated_generic_decl' +Result: <| GenericSubpDecl ["Bar"] test.adb:25:4-26:18 [test.adb:30:4] |> + +Eval 'bar_decl.p_parent_basic_decl' +Result: + +Set 'bar_body' to 'bar_decl.p_body_part()' +Result: <| NullSubpDecl ["Bar"] test.adb:28:4-28:26 [test.adb:30:4] |> + +Eval 'bar_body.p_parent_basic_decl' +Result: diff --git a/testsuite/tests/properties/parent_basic_decl_generic_body/test.yaml b/testsuite/tests/properties/parent_basic_decl_generic_body/test.yaml new file mode 100644 index 000000000..35ad4d5c4 --- /dev/null +++ b/testsuite/tests/properties/parent_basic_decl_generic_body/test.yaml @@ -0,0 +1,2 @@ +driver: inline-playground +input_sources: [test.adb]