From 6dd46553ad809721728d1d4d89825f024589cf87 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Laurent=20Th=C3=A9venoux?= <thevenoux@adacore.com>
Date: Wed, 6 Dec 2023 15:48:57 +0100
Subject: [PATCH] Fix accept statement xref_equation

This commit ensures that the entry index expression of an accept
statement is binded to the type defined by the corresponding entry
declaration.

As per ARM 9.5.2: the expected type for an entry index is that of the
subtype defined by the discrete subtype definition of the
corresponding entry declaration.
---
 ada/ast.py                                        |  8 +++++++-
 .../tests/name_resolution/accept_stmt/test.adb    | 15 +++++++++++++++
 .../tests/name_resolution/accept_stmt/test.out    | 13 +++++++++++++
 .../tests/name_resolution/accept_stmt/test.yaml   |  2 ++
 4 files changed, 37 insertions(+), 1 deletion(-)
 create mode 100644 testsuite/tests/name_resolution/accept_stmt/test.adb
 create mode 100644 testsuite/tests/name_resolution/accept_stmt/test.out
 create mode 100644 testsuite/tests/name_resolution/accept_stmt/test.yaml

diff --git a/ada/ast.py b/ada/ast.py
index a41df54cb..cbb34643a 100644
--- a/ada/ast.py
+++ b/ada/ast.py
@@ -22398,7 +22398,13 @@ def xref_equation():
         return And(
             Bind(Self.body_decl.name.ref_var, Entity.designated_entry),
             Entity.entry_index_expr.then(
-                lambda e: e.sub_equation,
+                lambda e:
+                # :rmlink:`9.5.2`: The expected type for entry_index_expr is
+                # that of the type defined by the definition of the
+                # corresponding entry declaration.
+                Bind(e.expected_type_var,
+                     Entity.designated_entry.family_type)
+                & e.sub_equation,
                 default_val=LogicTrue()
             )
         )
diff --git a/testsuite/tests/name_resolution/accept_stmt/test.adb b/testsuite/tests/name_resolution/accept_stmt/test.adb
new file mode 100644
index 000000000..c9c6c27e7
--- /dev/null
+++ b/testsuite/tests/name_resolution/accept_stmt/test.adb
@@ -0,0 +1,15 @@
+procedure Test is
+   task t is
+      entry ent1 (character);
+   end t;
+
+   task body t is
+   begin
+      accept ent1 ('c') do
+         null;
+      end;
+      pragma Test_Statement;
+   end t;
+begin
+   null;
+end Test;
diff --git a/testsuite/tests/name_resolution/accept_stmt/test.out b/testsuite/tests/name_resolution/accept_stmt/test.out
new file mode 100644
index 000000000..824576104
--- /dev/null
+++ b/testsuite/tests/name_resolution/accept_stmt/test.out
@@ -0,0 +1,13 @@
+Analyzing test.adb
+##################
+
+Resolving xrefs for node <AcceptStmtWithStmts test.adb:8:7-10:11>
+*****************************************************************
+
+Expr: <Chr "'c'" test.adb:8:20-8:23>
+  references:    <SyntheticDefiningName "'c'" __standard:21:3-21:27>
+  type:          <ConcreteTypeDecl ["Character"] __standard:21:3-21:27>
+  expected type: <ConcreteTypeDecl ["Character"] __standard:21:3-21:27>
+
+
+Done.
diff --git a/testsuite/tests/name_resolution/accept_stmt/test.yaml b/testsuite/tests/name_resolution/accept_stmt/test.yaml
new file mode 100644
index 000000000..173e325ff
--- /dev/null
+++ b/testsuite/tests/name_resolution/accept_stmt/test.yaml
@@ -0,0 +1,2 @@
+driver: name-resolution
+input_sources: [test.adb]