From c234c988a1d099cab928260aa1ae4add2291ccab Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Laurent=20Th=C3=A9venoux?= <thevenoux@adacore.com>
Date: Fri, 2 Feb 2024 10:25:45 +0100
Subject: [PATCH] gnat_xref: handle more cases for ParamSpec references

---
 ada/ast.py                                     | 18 +++++++++---------
 .../prj.gpr                                    |  4 ++++
 .../test.adb                                   | 13 +++++++++++++
 .../test.out                                   | 17 +++++++++++++++++
 .../test.yaml                                  |  2 ++
 5 files changed, 45 insertions(+), 9 deletions(-)
 create mode 100644 testsuite/tests/name_resolution/gnat_compare_body_subprogram_parameters/prj.gpr
 create mode 100644 testsuite/tests/name_resolution/gnat_compare_body_subprogram_parameters/test.adb
 create mode 100644 testsuite/tests/name_resolution/gnat_compare_body_subprogram_parameters/test.out
 create mode 100644 testsuite/tests/name_resolution/gnat_compare_body_subprogram_parameters/test.yaml

diff --git a/ada/ast.py b/ada/ast.py
index 9e918195c..ee6db89da 100644
--- a/ada/ast.py
+++ b/ada/ast.py
@@ -1634,20 +1634,20 @@ def gnat_xref():
                  .then(lambda dn: dn.basic_decl))
 
         return origin.bind(Self, Cond(
-            bd.then(lambda bd: bd.is_a(T.ParamSpec))
-            & bd.semantic_parent.is_a(T.SubpDecl, T.ExprFunction,
-                                      T.GenericSubpInternal,
-                                      T.BaseTypeDecl),
+            bd._.is_a(T.ParamSpec)
+            & Or(
+                bd.semantic_parent.is_a(T.BasicSubpDecl, T.ExprFunction,
+                                        T.BaseTypeDecl, T.SubpBodyStub,
+                                        T.NullSubpDecl),
+                bd.semantic_parent.cast(T.SubpBody).then(
+                    lambda body: body.previous_part_for_decl.is_null
+                )
+            ),
             bd.semantic_parent.cast(T.BasicDecl).defining_name,
 
             bd.then(lambda bd: bd.is_a(T.DiscriminantSpec)),
             bd.semantic_parent.cast(T.BasicDecl).defining_name,
 
-            bd.then(lambda bd: bd.is_a(T.ParamSpec))
-            & bd.semantic_parent.is_a(T.AbstractSubpDecl, T.FormalSubpDecl,
-                                      T.NullSubpDecl),
-            bd.semantic_parent.cast(T.BasicDecl).defining_name,
-
             bd.then(lambda bd: bd.is_a(T.AbstractSubpDecl)),
             bd.cast(T.AbstractSubpDecl).subp_decl_spec
             .primitive_subp_first_type.defining_name,
diff --git a/testsuite/tests/name_resolution/gnat_compare_body_subprogram_parameters/prj.gpr b/testsuite/tests/name_resolution/gnat_compare_body_subprogram_parameters/prj.gpr
new file mode 100644
index 000000000..4b29ca3fd
--- /dev/null
+++ b/testsuite/tests/name_resolution/gnat_compare_body_subprogram_parameters/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_body_subprogram_parameters/test.adb b/testsuite/tests/name_resolution/gnat_compare_body_subprogram_parameters/test.adb
new file mode 100644
index 000000000..e735cda3d
--- /dev/null
+++ b/testsuite/tests/name_resolution/gnat_compare_body_subprogram_parameters/test.adb
@@ -0,0 +1,13 @@
+procedure Test is
+   function F
+     (I : in     Integer;
+      J : in out Integer;
+      K : out    Integer;
+      L : access Integer) return Integer is
+   begin
+      return 0;
+   end F;
+   --  I, J, K, L references to F should be ignored by gnat_compare
+begin
+   null;
+end;
diff --git a/testsuite/tests/name_resolution/gnat_compare_body_subprogram_parameters/test.out b/testsuite/tests/name_resolution/gnat_compare_body_subprogram_parameters/test.out
new file mode 100644
index 000000000..2a15d39e5
--- /dev/null
+++ b/testsuite/tests/name_resolution/gnat_compare_body_subprogram_parameters/test.out
@@ -0,0 +1,17 @@
+== test.adb ==
+test.adb:1:11 => test.adb:1:11 (LAL: ok)
+test.adb:2:13 => test.adb:2:13 (LAL: ok)
+test.adb:3:7 => test.adb:2:13 (LAL: ok)
+test.adb:4:7 => test.adb:2:13 (LAL: ok)
+test.adb:5:7 => test.adb:2:13 (LAL: ok)
+test.adb:6:7 => test.adb:2:13 (LAL: ok)
+test.adb:9:8 => test.adb:2:13 (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_body_subprogram_parameters/test.yaml b/testsuite/tests/name_resolution/gnat_compare_body_subprogram_parameters/test.yaml
new file mode 100644
index 000000000..9efa742f3
--- /dev/null
+++ b/testsuite/tests/name_resolution/gnat_compare_body_subprogram_parameters/test.yaml
@@ -0,0 +1,2 @@
+driver: gnat-compare
+project_file: prj.gpr