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 --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.
