From d76d71cd93c59d253bbdfcae24eac1a1ba410bb7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Laurent=20Th=C3=A9venoux?= Date: Tue, 30 Jan 2024 16:54:27 +0100 Subject: [PATCH] gnat_compare: body name/end_name refer to the specification's name GNAT xref for a body name/endname points to the defining name of the corresponding spec (if any), while libadalang points to the defining name of the body. --- ada/ast.py | 10 ++--- testsuite/ada/gnat_compare/gnat_compare.adb | 2 +- testsuite/ada/gnat_compare/xrefs_wrapper.adb | 39 +++++++++++++++---- testsuite/ada/gnat_compare/xrefs_wrapper.ads | 27 +++++++++---- .../name_resolution/gnat_compare_2/test.adb | 2 + .../name_resolution/gnat_compare_2/test.out | 8 ++-- .../name_resolution/gnat_compare_3/pkg.adb | 2 + .../name_resolution/gnat_compare_3/pkg.ads | 3 ++ .../name_resolution/gnat_compare_3/prj.gpr | 4 ++ .../name_resolution/gnat_compare_3/test.adb | 6 +++ .../name_resolution/gnat_compare_3/test.out | 19 +++++++++ .../name_resolution/gnat_compare_3/test.yaml | 2 + .../name_resolution/gnat_compare_4/prj.gpr | 4 ++ .../name_resolution/gnat_compare_4/test.adb | 29 ++++++++++++++ .../name_resolution/gnat_compare_4/test.out | 22 +++++++++++ .../name_resolution/gnat_compare_4/test.yaml | 2 + 16 files changed, 156 insertions(+), 25 deletions(-) create mode 100644 testsuite/tests/name_resolution/gnat_compare_3/pkg.adb create mode 100644 testsuite/tests/name_resolution/gnat_compare_3/pkg.ads create mode 100644 testsuite/tests/name_resolution/gnat_compare_3/prj.gpr create mode 100644 testsuite/tests/name_resolution/gnat_compare_3/test.adb create mode 100644 testsuite/tests/name_resolution/gnat_compare_3/test.out create mode 100644 testsuite/tests/name_resolution/gnat_compare_3/test.yaml create mode 100644 testsuite/tests/name_resolution/gnat_compare_4/prj.gpr create mode 100644 testsuite/tests/name_resolution/gnat_compare_4/test.adb create mode 100644 testsuite/tests/name_resolution/gnat_compare_4/test.out create mode 100644 testsuite/tests/name_resolution/gnat_compare_4/test.yaml diff --git a/ada/ast.py b/ada/ast.py index 400281b0c..e26e143c5 100644 --- a/ada/ast.py +++ b/ada/ast.py @@ -1683,10 +1683,8 @@ def gnat_xref(): lambda ppd: ppd.defining_name )._or(ret), - - dbd.is_a(T.BaseSubpBody), - dbd.cast(T.BaseSubpBody) - .decl_part._or(dbd).defining_name, + dbd.is_a(T.Body), + dbd.cast(T.Body).decl_part._or(dbd).defining_name, ret )) @@ -14997,9 +14995,7 @@ def gnat_xref_decl(): # Number decls cannot have a next part, always return None No(T.DefiningName.entity), - bd.then(lambda bd: bd.is_a(BasicDecl)), - bd.body_part_for_decl.then(lambda bpe: bpe.defining_name) - ._or(bd.defining_name), + bd.then(lambda bd: bd.is_a(BasicDecl)), dn, Entity.referenced_defining_name ) diff --git a/testsuite/ada/gnat_compare/gnat_compare.adb b/testsuite/ada/gnat_compare/gnat_compare.adb index 9c05b2309..b94873a20 100644 --- a/testsuite/ada/gnat_compare/gnat_compare.adb +++ b/testsuite/ada/gnat_compare/gnat_compare.adb @@ -450,7 +450,7 @@ procedure GNAT_Compare is if not Ref.Is_Null then for Wrapper of Xrefs_Wrapper.Post_Wrappers loop declare - Wrapped_Ref : constant Defining_Name := Wrapper (Ref); + Wrapped_Ref : constant Defining_Name := Wrapper (Node, Ref); begin if not Wrapped_Ref.Is_Null then return Wrapped_Ref; diff --git a/testsuite/ada/gnat_compare/xrefs_wrapper.adb b/testsuite/ada/gnat_compare/xrefs_wrapper.adb index 22d1d1342..39756b8c3 100644 --- a/testsuite/ada/gnat_compare/xrefs_wrapper.adb +++ b/testsuite/ada/gnat_compare/xrefs_wrapper.adb @@ -1,3 +1,5 @@ +pragma Ada_2022; + with Libadalang.Common; use Libadalang.Common; package body Xrefs_Wrapper is @@ -13,7 +15,10 @@ package body Xrefs_Wrapper is -- Subp_Body_Formal -- ---------------------- - function Subp_Body_Formal (DN : Defining_Name) return Defining_Name is + function Subp_Body_Formal + (Origin : Ada_Node with Unreferenced; + DN : Defining_Name) return Defining_Name + is Subp_Body : Ada_Node; Subp_Decl : Basic_Subp_Decl; Decl : constant Basic_Decl := DN.P_Basic_Decl; @@ -56,7 +61,10 @@ package body Xrefs_Wrapper is -- Subp_Body -- --------------- - function Subp_Body (DN : Defining_Name) return Defining_Name is + function Subp_Body + (Origin : Ada_Node with Unreferenced; + DN : Defining_Name) return Defining_Name + is Decl : constant Basic_Decl := DN.P_Basic_Decl; begin if Decl.Kind /= Ada_Subp_Body then @@ -70,7 +78,10 @@ package body Xrefs_Wrapper is -- Generic_Package -- --------------------- - function Generic_Package (DN : Defining_Name) return Defining_Name is + function Generic_Package + (Origin : Ada_Node with Unreferenced; + DN : Defining_Name) return Defining_Name + is Decl : constant Basic_Decl := DN.P_Basic_Decl; begin if Decl.Kind /= Ada_Generic_Package_Decl then @@ -86,7 +97,10 @@ package body Xrefs_Wrapper is -- Generic_Subp -- ------------------ - function Generic_Subp (DN : Defining_Name) return Defining_Name is + function Generic_Subp + (Origin : Ada_Node with Unreferenced; + DN : Defining_Name) return Defining_Name + is Decl : constant Basic_Decl := DN.P_Basic_Decl; begin if Decl.Kind /= Ada_Generic_Subp_Decl then @@ -101,10 +115,21 @@ package body Xrefs_Wrapper is -- Private_Type -- ------------------ - function Private_Type (DN : Defining_Name) return Defining_Name is - Decl : constant Basic_Decl := DN.P_Basic_Decl; + function Private_Type + (Origin : Ada_Node; + DN : Defining_Name) return Defining_Name + is + Decl : constant Basic_Decl := DN.P_Basic_Decl; + Origin_Decl : constant Basic_Decl := Origin.P_Parent_Basic_Decl; begin - if Decl.Kind not in Ada_Base_Type_Decl then + if Decl.Kind not in Ada_Base_Type_Decl + or else + (Decl.Kind in Ada_Task_Type_Decl + and then + (Decl.P_Declarative_Scope.Is_Null + or else Decl.P_Declarative_Scope.Kind not in Ada_Private_Part) + and then Origin_Decl.Kind in Ada_Task_Type_Decl | Ada_Task_Body) + then return No_Defining_Name; end if; diff --git a/testsuite/ada/gnat_compare/xrefs_wrapper.ads b/testsuite/ada/gnat_compare/xrefs_wrapper.ads index 247276356..ca92a508e 100644 --- a/testsuite/ada/gnat_compare/xrefs_wrapper.ads +++ b/testsuite/ada/gnat_compare/xrefs_wrapper.ads @@ -9,13 +9,17 @@ package Xrefs_Wrapper is access function (Node : Ada_Node) return Defining_Name; type Post_Wrapper_Type is - access function (Decl : Defining_Name) return Defining_Name; + access function + (Origin : Ada_Node; + Decl : Defining_Name) return Defining_Name; -- All the functions below target a specific construct from LAL's . When -- they matches this construct, they try to find the entity that GNAT xref -- would yield and return it. Otherwise they return No_Basic_Decl. - function Subp_Body_Formal (DN : Defining_Name) return Defining_Name; + function Subp_Body_Formal + (Origin : Ada_Node; + DN : Defining_Name) return Defining_Name; -- When a subprogram has both a declaration and a body, GNAT resolves -- references to its formals in the body to the formal declarations in the -- declaration, while LAL resolves to the formal declaration in the body. @@ -23,7 +27,9 @@ package Xrefs_Wrapper is -- If Decl is formal declaration in a subprogram body, return the -- corresponding declaration in the subprogram declaration. - function Subp_Body (DN : Defining_Name) return Defining_Name; + function Subp_Body + (Origin : Ada_Node; + DN : Defining_Name) return Defining_Name; -- When a subprogram has both a declaration and a body, GNAT resolves -- references to this subprogram (like in calls) that have visibility -- on both to the declaration, while LAL resolves to the body. @@ -31,24 +37,31 @@ package Xrefs_Wrapper is -- If Decl is a subprogram body that has a separate declaration, return the -- corresponding declaration. - function Generic_Package (DN : Defining_Name) return Defining_Name; + function Generic_Package + (Origin : Ada_Node; + DN : Defining_Name) return Defining_Name; -- GNAT resolves to the identifier of a generic package whereas LAL -- resolves to the top-level "generic" declaration. -- -- If Decl is a Generic_Package_Decl, return the underlying -- Generic_Package_Internal node. - function Generic_Subp (DN : Defining_Name) return Defining_Name; + function Generic_Subp + (Origin : Ada_Node; + DN : Defining_Name) return Defining_Name; -- GNAT resolves to the identifier of a generic procedure whereas LAL -- resolves to the top-level "generic" declaration. -- -- If Decl is a Generic_Subp_Decl, return the underlying -- Generic_Subp_Internal node. - function Private_Type (DN : Defining_Name) return Defining_Name; + function Private_Type + (Origin : Ada_Node; + DN : Defining_Name) return Defining_Name; -- GNAT resolves type references to the first part of a type declaration -- (the incomplete one, or the private one) whereas LAL resolves to the - -- most complete view. + -- most complete view (except for task body names that refers to the task + -- declaration and not the potential incomplete type it derives from). -- -- If Decl is a Base_Type_Decl, return the result of P_Previous_Part -- (Go_To_Incomplete => True). diff --git a/testsuite/tests/name_resolution/gnat_compare_2/test.adb b/testsuite/tests/name_resolution/gnat_compare_2/test.adb index f6d4ebdfe..16bfa5a6c 100644 --- a/testsuite/tests/name_resolution/gnat_compare_2/test.adb +++ b/testsuite/tests/name_resolution/gnat_compare_2/test.adb @@ -3,6 +3,8 @@ procedure Test is private type I is new Integer; end P; + package body P is + end P; begin null; end Test; diff --git a/testsuite/tests/name_resolution/gnat_compare_2/test.out b/testsuite/tests/name_resolution/gnat_compare_2/test.out index 2c1348866..a62842d43 100644 --- a/testsuite/tests/name_resolution/gnat_compare_2/test.out +++ b/testsuite/tests/name_resolution/gnat_compare_2/test.out @@ -1,12 +1,14 @@ == test.adb == test.adb:1:11 => test.adb:1:11 (LAL: ok) test.adb:5:8 => test.adb:2:12 (LAL: ok) -test.adb:8:5 => test.adb:1:11 (LAL: ok) +test.adb:6:17 => test.adb:2:12 (LAL: ok) +test.adb:7:8 => test.adb:2:12 (LAL: ok) +test.adb:10:5 => test.adb:1:11 (LAL: ok) Stats: -GNAT xrefs have 3 entries +GNAT xrefs have 5 entries LAL xrefs have: - * 3 OK entries (100.00%) + * 5 OK entries (100.00%) * 0 DIFFERENT entries (0.00%) * 0 ERROR entries (0.00%) * 0 MISSING entries (0.00%) diff --git a/testsuite/tests/name_resolution/gnat_compare_3/pkg.adb b/testsuite/tests/name_resolution/gnat_compare_3/pkg.adb new file mode 100644 index 000000000..bea18af50 --- /dev/null +++ b/testsuite/tests/name_resolution/gnat_compare_3/pkg.adb @@ -0,0 +1,2 @@ +package body Pkg is +end Pkg; diff --git a/testsuite/tests/name_resolution/gnat_compare_3/pkg.ads b/testsuite/tests/name_resolution/gnat_compare_3/pkg.ads new file mode 100644 index 000000000..ff6d97271 --- /dev/null +++ b/testsuite/tests/name_resolution/gnat_compare_3/pkg.ads @@ -0,0 +1,3 @@ +package Pkg is +end Pkg; +pragma Elaborate_Body (Pkg); diff --git a/testsuite/tests/name_resolution/gnat_compare_3/prj.gpr b/testsuite/tests/name_resolution/gnat_compare_3/prj.gpr new file mode 100644 index 000000000..4b29ca3fd --- /dev/null +++ b/testsuite/tests/name_resolution/gnat_compare_3/prj.gpr @@ -0,0 +1,4 @@ +project Prj is + for Source_Dirs use ("."); + for Main use ("test.adb"); +end Prj; diff --git a/testsuite/tests/name_resolution/gnat_compare_3/test.adb b/testsuite/tests/name_resolution/gnat_compare_3/test.adb new file mode 100644 index 000000000..64183a020 --- /dev/null +++ b/testsuite/tests/name_resolution/gnat_compare_3/test.adb @@ -0,0 +1,6 @@ +with Pkg; + +procedure Test is +begin + null; +end Test; diff --git a/testsuite/tests/name_resolution/gnat_compare_3/test.out b/testsuite/tests/name_resolution/gnat_compare_3/test.out new file mode 100644 index 000000000..12f0d0ab6 --- /dev/null +++ b/testsuite/tests/name_resolution/gnat_compare_3/test.out @@ -0,0 +1,19 @@ +== pkg.adb == +pkg.adb:1:14 => pkg.ads:1:9 (LAL: ok) +pkg.adb:2:5 => pkg.ads:1:9 (LAL: ok) +== pkg.ads == +pkg.ads:2:5 => pkg.ads:1:9 (LAL: ok) +pkg.ads:3:24 => pkg.ads:1:9 (LAL: ok) +== test.adb == +test.adb:1:6 => pkg.ads:1:9 (LAL: ok) +test.adb:3:11 => test.adb:3:11 (LAL: ok) +test.adb:6:5 => test.adb:3:11 (LAL: ok) + +Stats: +GNAT xrefs have 7 entries +LAL xrefs have: + * 7 OK entries (100.00%) + * 0 DIFFERENT entries (0.00%) + * 0 ERROR entries (0.00%) + * 0 MISSING entries (0.00%) + * 0 ADDITIONAL entries (0.00%) diff --git a/testsuite/tests/name_resolution/gnat_compare_3/test.yaml b/testsuite/tests/name_resolution/gnat_compare_3/test.yaml new file mode 100644 index 000000000..9efa742f3 --- /dev/null +++ b/testsuite/tests/name_resolution/gnat_compare_3/test.yaml @@ -0,0 +1,2 @@ +driver: gnat-compare +project_file: prj.gpr diff --git a/testsuite/tests/name_resolution/gnat_compare_4/prj.gpr b/testsuite/tests/name_resolution/gnat_compare_4/prj.gpr new file mode 100644 index 000000000..4b29ca3fd --- /dev/null +++ b/testsuite/tests/name_resolution/gnat_compare_4/prj.gpr @@ -0,0 +1,4 @@ +project Prj is + for Source_Dirs use ("."); + for Main use ("test.adb"); +end Prj; diff --git a/testsuite/tests/name_resolution/gnat_compare_4/test.adb b/testsuite/tests/name_resolution/gnat_compare_4/test.adb new file mode 100644 index 000000000..7091810e0 --- /dev/null +++ b/testsuite/tests/name_resolution/gnat_compare_4/test.adb @@ -0,0 +1,29 @@ +procedure Test is + package P is + type T; + type U is limited private; + + task type T is + end T; -- refers to T line 6 + private + task type U is + end U; -- refers to U line 4 + end P; + + package body P is + task body T is -- refers to T line 6 + begin + null; + end T; -- refers to T line 6 + + task body U is -- refers to U line 4 + begin + null; + end U; -- refers to U line 4 + end P; + use P; + + My_T : T; -- refers to T line 3 +begin + null; +end; diff --git a/testsuite/tests/name_resolution/gnat_compare_4/test.out b/testsuite/tests/name_resolution/gnat_compare_4/test.out new file mode 100644 index 000000000..f1ed68de8 --- /dev/null +++ b/testsuite/tests/name_resolution/gnat_compare_4/test.out @@ -0,0 +1,22 @@ +== test.adb == +test.adb:1:11 => test.adb:1:11 (LAL: ok) +test.adb:7:11 => test.adb:6:17 (LAL: ok) +test.adb:10:11 => test.adb:4:12 (LAL: ok) +test.adb:11:8 => test.adb:2:12 (LAL: ok) +test.adb:13:17 => test.adb:2:12 (LAL: ok) +test.adb:14:17 => test.adb:6:17 (LAL: ok) +test.adb:17:11 => test.adb:6:17 (LAL: ok) +test.adb:19:17 => test.adb:4:12 (LAL: ok) +test.adb:22:11 => test.adb:4:12 (LAL: ok) +test.adb:23:8 => test.adb:2:12 (LAL: ok) +test.adb:24:8 => test.adb:2:12 (LAL: ok) +test.adb:26:11 => test.adb:3:12 (LAL: ok) + +Stats: +GNAT xrefs have 12 entries +LAL xrefs have: + * 12 OK entries (100.00%) + * 0 DIFFERENT entries (0.00%) + * 0 ERROR entries (0.00%) + * 0 MISSING entries (0.00%) + * 0 ADDITIONAL entries (0.00%) diff --git a/testsuite/tests/name_resolution/gnat_compare_4/test.yaml b/testsuite/tests/name_resolution/gnat_compare_4/test.yaml new file mode 100644 index 000000000..9efa742f3 --- /dev/null +++ b/testsuite/tests/name_resolution/gnat_compare_4/test.yaml @@ -0,0 +1,2 @@ +driver: gnat-compare +project_file: prj.gpr