diff mbox series

[Ada] Avoid inappropriate error messages regarding aggregates and variant parts

Message ID 20210615102051.GA2546@adacore.com
State New
Headers show
Series [Ada] Avoid inappropriate error messages regarding aggregates and variant parts | expand

Commit Message

Pierre-Marie de Rodat June 15, 2021, 10:20 a.m. UTC 
An aggregate of a type that has a variant part has to satisfy certain
rules about the discriminant value governing that variant part. If these
rules are violated, then the front end typically emits a message
associated with the discriminant value. However, this is not useful in
the case where the discriminant value does not come from the aggregate.
This can occur if we have a discriminated tagged type with a variant
part, a type extension that declares a new discriminant (and supplies a
value for the old discriminant), and (later) an aggregate of the
extension type. This case was not being handled correctly in an
Ada_2020-only case.

One might reasonably wonder whether this decision to not generate an
error message could lead to problems with incorrectly accepting some
unit that ought to be rejected; the answer is quite the opposite - this
error message suppression is needed for correctness in order to avoid
rejecting units that ought to be accepted.

Tested on x86_64-pc-linux-gnu, committed on trunk

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 mbox series

Patch

diff --git a/gcc/ada/sem_util.adb b/gcc/ada/sem_util.adb
--- 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
--- 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.