[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 --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
index 01690f3a35e7f9774a77d17fc1447d6289e2e343..73a6f79f36fa850931abe6764d70bd60bb0fe310 100644 (file)
--- 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 83791fc271eaa13d1eee1fc510f9534e30cdf84b..2e26c283d71a9c27c138d1f5d5b6100cf0216175 100644 (file)
--- 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.