[gcc r12-1452] [Ada] Avoid inappropriate error messages regarding aggregates and variant parts

[gcc r12-1452] [Ada] Avoid inappropriate error messages regarding aggregates and variant parts

[Pierre-Marie de Rodat]

https://gcc.gnu.org/g:4dbdeeb889dfd4dcce214e1525b56a7464128a3c

commit r12-1452-g4dbdeeb889dfd4dcce214e1525b56a7464128a3c
Author: Steve Baird <baird@adacore.com>
Date:   Wed Feb 17 17:54:53 2021 -0800

    [Ada] Avoid inappropriate error messages regarding aggregates and variant parts
    
    gcc/ada/
    
            * sem_util.adb (Gather_Components): Factor the test that was
            already being used to govern emitting a pre-Ada_2020 error
            message into an expression function,
            OK_Scope_For_Discrim_Value_Error_Messages. Call that new
            function in two places: the point where the same test was being
            performed previously, and in governing emission of a newer
            Ada_2020 error message. In both cases, the out-mode parameter
            Gather_Components.Report_Errors is set to True even if no error
            messages are generated within Gather_Components.
            * sem_util.ads: Correct a comment.

Diff:
---
 gcc/ada/sem_util.adb | 26 +++++++++++++++++++-------
 gcc/ada/sem_util.ads |  3 ++-
 2 files changed, 21 insertions(+), 8 deletions(-)

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 01690f3a35e..73a6f79f36f 100644
--- a/gcc/ada/sem_util.adb
+++ b/gcc/ada/sem_util.adb
@@ -9990,6 +9990,18 @@ package body Sem_Util is
       Discrim_Value         : Node_Id;
       Discrim_Value_Subtype : Node_Id;
       Discrim_Value_Status  : Discriminant_Value_Status := Bad;
+
+      function OK_Scope_For_Discrim_Value_Error_Messages return Boolean is
+        (Scope (Original_Record_Component
+                        (Entity (First (Choices (Assoc))))) = Typ);
+      --  Used to avoid generating error messages having a source position
+      --  which refers to somewhere (e.g., a discriminant value in a derived
+      --  tagged type declaration) unrelated to the offending construct. This
+      --  is required for correctness - clients of Gather_Components such as
+      --  Sem_Ch3.Create_Constrained_Components depend on this function
+      --  returning True while processing semantically correct examples;
+      --  generating an error message in this case would be wrong.
+
    begin
       Report_Errors := False;
 
@@ -10178,9 +10190,7 @@ package body Sem_Util is
             --  every value of that subtype (and there must be at least one)
             --  selects the same variant.
 
-            if Scope (Original_Record_Component
-                        ((Entity (First (Choices (Assoc)))))) = Typ
-            then
+            if OK_Scope_For_Discrim_Value_Error_Messages then
                if Ada_Version >= Ada_2020 then
                   Error_Msg_FE
                     ("value for discriminant & must be static or " &
@@ -10299,10 +10309,12 @@ package body Sem_Util is
                         (Subset => Discrim_Value_Subtype_Intervals,
                          Of_Set => Variant_Intervals)
                then
-                  Error_Msg_NE
-                    ("no single variant is associated with all values of " &
-                     "the subtype of discriminant value &",
-                     Discrim_Value, Discrim);
+                  if OK_Scope_For_Discrim_Value_Error_Messages then
+                     Error_Msg_NE
+                       ("no single variant is associated with all values of " &
+                        "the subtype of discriminant value &",
+                        Discrim_Value, Discrim);
+                  end if;
                   Report_Errors := True;
                   return;
                end if;
diff --git a/gcc/ada/sem_util.ads b/gcc/ada/sem_util.ads
index 83791fc271e..2e26c283d71 100644
--- a/gcc/ada/sem_util.ads
+++ b/gcc/ada/sem_util.ads
@@ -1079,7 +1079,8 @@ package Sem_Util is
    --     to its tail.
    --
    --    Report_Errors is set to True if the values of the discriminants are
-   --     non-static.
+   --     insufficiently static (see body for details of what that means).
+
    --
    --    Allow_Compile_Time if set to True, allows compile time known values in
    --     Governed_By expressions in addition to static expressions.