Merge branch 'topic/1233' into 'master'

gnat_compare: body name/end_name refer to the specification's name

Closes #1233

See merge request eng/libadalang/libadalang!1520

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
         )

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;

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;
 

testsuite/ada/gnat_compare/xrefs_wrapper.ads

@@ -9,46 +9,59 @@ 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.
    --
    --  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.
    --
    --  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).

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;

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%)

testsuite/tests/name_resolution/gnat_compare_3/pkg.adb

@@ -0,0 +1,2 @@
+package body Pkg is
+end Pkg;

testsuite/tests/name_resolution/gnat_compare_3/pkg.ads

@@ -0,0 +1,3 @@
+package Pkg is
+end Pkg;
+pragma Elaborate_Body (Pkg);

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;

testsuite/tests/name_resolution/gnat_compare_3/test.adb

@@ -0,0 +1,6 @@
+with Pkg;
+
+procedure Test is
+begin
+   null;
+end Test;

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%)

testsuite/tests/name_resolution/gnat_compare_3/test.yaml

@@ -0,0 +1,2 @@
+driver: gnat-compare
+project_file: prj.gpr

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;

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;

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%)

testsuite/tests/name_resolution/gnat_compare_4/test.yaml

@@ -0,0 +1,2 @@
+driver: gnat-compare
+project_file: prj.gpr