This implements the AI in all versions of the language, since it is a
binding interpretation. The AI extends the 12.5.1(8) subclause: "For
a generic formal derived type with no discriminant_part, the actual
subtype shall be statically compatible with the ancestor subtype"
from constained types to unconstrained types.
It turns out that this extension was already implemented in GNAT and
constrained and unconstrained types were already treated alike here.
So the change only tweaks the error message to mention the ancestor.
However, in Ada 2012 the "statically compatible" property comprises
a condition on the predicates present on the subtypes which was not
implemented yet so this change implements it, with a limitation for
static subtypes that are not discrete.
A duplicate error handling pattern is also factored out in Sem_Ch3.
Tested on x86_64-pc-linux-gnu, committed on trunk
2020-06-16 Eric Botcazou <ebotca...@adacore.com>
gcc/ada/
* sem_ch12.adb (Validate_Derived_Type_Instance): Reword error
message for 12.5.1(8) subclause and add secondary message if
the incompatibility comes from the predicates.
* sem_ch3.adb (Check_Constraining_Discriminant): New procedure
to give the error required by the 3.7(15) subclause. Mention
"statically" in the error message and add secondary message
if the incompatibility comes from the predicates.
(Build_Derived_Concurrent_Type): Call it when a new discriminant
constrains an old one.
(Build_Derived_Record_Type): Likewise.
* sem_eval.ads (Predicates_Compatible): Declare.
* sem_eval.adb (Predicates_Compatible): New function to implement
the compatibility of predicates specified by the 4.9.1 clause.
(Subtypes_Statically_Compatible): Call it.--- gcc/ada/sem_ch12.adb
+++ gcc/ada/sem_ch12.adb
@@ -13321,8 +13321,16 @@ package body Sem_Ch12 is
if not Subtypes_Statically_Compatible
(Act_T, Ancestor, Formal_Derived_Matching => True)
then
- Error_Msg_N
- ("constraint on actual is incompatible with formal", Actual);
+ Error_Msg_NE
+ ("actual for & must be statically compatible with ancestor",
+ Actual, Gen_T);
+
+ if not Predicates_Compatible (Act_T, Ancestor) then
+ Error_Msg_N
+ ("\predicate on actual is not compatible with ancestor",
+ Actual);
+ end if;
+
Abandon_Instantiation (Actual);
end if;
end if;
--- gcc/ada/sem_ch3.adb
+++ gcc/ada/sem_ch3.adb
@@ -254,6 +254,11 @@ package body Sem_Ch3 is
-- circularity issues in Gigi. We create an incomplete type for the record
-- declaration, which is the designated type of the anonymous access.
+ procedure Check_Constraining_Discriminant (New_Disc, Old_Disc : Entity_Id);
+ -- Check that, if a new discriminant is used in a constraint defining the
+ -- parent subtype of a derivation, its subtype is statically compatible
+ -- with the subtype of the corresponding parent discriminant (RM 3.7(15)).
+
procedure Check_Delta_Expression (E : Node_Id);
-- Check that the expression represented by E is suitable for use as a
-- delta expression, i.e. it is of real type and is static.
@@ -6906,14 +6911,13 @@ package body Sem_Ch3 is
Error_Msg_NE
("new discriminant& must constrain old one", N, New_Disc);
- elsif not
- Subtypes_Statically_Compatible
- (Etype (New_Disc),
- Etype (Corresponding_Discriminant (New_Disc)))
- then
- Error_Msg_NE
- ("& not statically compatible with parent discriminant",
- N, New_Disc);
+ -- If a new discriminant is used in the constraint, then its
+ -- subtype must be statically compatible with the subtype of
+ -- the parent discriminant (RM 3.7(15)).
+
+ else
+ Check_Constraining_Discriminant
+ (New_Disc, Corresponding_Discriminant (New_Disc));
end if;
Next_Discriminant (New_Disc);
@@ -9087,41 +9091,13 @@ package body Sem_Ch3 is
end if;
-- If a new discriminant is used in the constraint, then its
- -- subtype must be statically compatible with the parent
- -- discriminant's subtype (3.7(15)).
-
- -- However, if the record contains an array constrained by
- -- the discriminant but with some different bound, the compiler
- -- tries to create a smaller range for the discriminant type.
- -- (See exp_ch3.Adjust_Discriminants). In this case, where
- -- the discriminant type is a scalar type, the check must use
- -- the original discriminant type in the parent declaration.
-
- declare
- Corr_Disc : constant Entity_Id :=
- Corresponding_Discriminant (Discrim);
- Disc_Type : constant Entity_Id := Etype (Discrim);
- Corr_Type : Entity_Id;
+ -- subtype must be statically compatible with the subtype of
+ -- the parent discriminant (RM 3.7(15)).
- begin
- if Present (Corr_Disc) then
- if Is_Scalar_Type (Disc_Type) then
- Corr_Type :=
- Entity (Discriminant_Type (Parent (Corr_Disc)));
- else
- Corr_Type := Etype (Corr_Disc);
- end if;
-
- if not
- Subtypes_Statically_Compatible (Disc_Type, Corr_Type)
- then
- Error_Msg_N
- ("subtype must be compatible "
- & "with parent discriminant",
- Discrim);
- end if;
- end if;
- end;
+ if Present (Corresponding_Discriminant (Discrim)) then
+ Check_Constraining_Discriminant
+ (Discrim, Corresponding_Discriminant (Discrim));
+ end if;
Next_Discriminant (Discrim);
end loop;
@@ -11623,6 +11599,41 @@ package body Sem_Ch3 is
end loop;
end Check_Completion;
+ -------------------------------------
+ -- Check_Constraining_Discriminant --
+ -------------------------------------
+
+ procedure Check_Constraining_Discriminant (New_Disc, Old_Disc : Entity_Id)
+ is
+ New_Type : constant Entity_Id := Etype (New_Disc);
+ Old_Type : Entity_Id;
+
+ begin
+ -- If the record type contains an array constrained by the discriminant
+ -- but with some different bound, the compiler tries to create a smaller
+ -- range for the discriminant type (see exp_ch3.Adjust_Discriminants).
+ -- In this case, where the discriminant type is a scalar type, the check
+ -- must use the original discriminant type in the parent declaration.
+
+ if Is_Scalar_Type (New_Type) then
+ Old_Type := Entity (Discriminant_Type (Parent (Old_Disc)));
+ else
+ Old_Type := Etype (Old_Disc);
+ end if;
+
+ if not Subtypes_Statically_Compatible (New_Type, Old_Type) then
+ Error_Msg_N
+ ("subtype must be statically compatible with parent discriminant",
+ New_Disc);
+
+ if not Predicates_Compatible (New_Type, Old_Type) then
+ Error_Msg_N
+ ("\subtype predicate is not compatible with parent discriminant",
+ New_Disc);
+ end if;
+ end if;
+ end Check_Constraining_Discriminant;
+
------------------------------------
-- Check_CPP_Type_Has_No_Defaults --
------------------------------------
--- gcc/ada/sem_eval.adb
+++ gcc/ada/sem_eval.adb
@@ -5616,6 +5616,84 @@ package body Sem_Eval is
end if;
end Out_Of_Range;
+ ---------------------------
+ -- Predicates_Compatible --
+ ---------------------------
+
+ function Predicates_Compatible (T1, T2 : Entity_Id) return Boolean is
+
+ function T2_Rep_Item_Applies_To_T1 (Nam : Name_Id) return Boolean;
+ -- Return True if the rep item for Nam is either absent on T2 or also
+ -- applies to T1.
+
+ -------------------------------
+ -- T2_Rep_Item_Applies_To_T1 --
+ -------------------------------
+
+ function T2_Rep_Item_Applies_To_T1 (Nam : Name_Id) return Boolean is
+ Rep_Item : constant Node_Id := Get_Rep_Item (T2, Nam);
+
+ begin
+ return No (Rep_Item) or else Get_Rep_Item (T1, Nam) = Rep_Item;
+ end T2_Rep_Item_Applies_To_T1;
+
+ -- Start of processing for Predicates_Compatible
+
+ begin
+ if Ada_Version < Ada_2012 then
+ return True;
+
+ -- If T2 has no predicates, there is no compatibility issue
+
+ elsif not Has_Predicates (T2) then
+ return True;
+
+ -- T2 has predicates, if T1 has none then we defer to the static check
+
+ elsif not Has_Predicates (T1) then
+ null;
+
+ -- Both T2 and T1 have predicates, check that all predicates that apply
+ -- to T2 apply also to T1 (RM 4.9.1(9/3)).
+
+ elsif T2_Rep_Item_Applies_To_T1 (Name_Static_Predicate)
+ and then T2_Rep_Item_Applies_To_T1 (Name_Dynamic_Predicate)
+ and then T2_Rep_Item_Applies_To_T1 (Name_Predicate)
+ then
+ return True;
+ end if;
+
+ -- Implement the static check prescribed by RM 4.9.1(10/3)
+
+ if Is_Static_Subtype (T1) and then Is_Static_Subtype (T2) then
+ -- We just need to query Interval_Lists for discrete types
+
+ if Is_Discrete_Type (T1) and then Is_Discrete_Type (T2) then
+ declare
+ Interval_List1 : constant Interval_Lists.Discrete_Interval_List
+ := Interval_Lists.Type_Intervals (T1);
+ Interval_List2 : constant Interval_Lists.Discrete_Interval_List
+ := Interval_Lists.Type_Intervals (T2);
+ begin
+ return Interval_Lists.Is_Subset (Interval_List1, Interval_List2)
+ and then not (Has_Predicates (T1)
+ and then not Predicate_Checks_Suppressed (T2)
+ and then Predicate_Checks_Suppressed (T1));
+ end;
+
+ else
+ -- TBD: Implement Interval_Lists for real types
+
+ return False;
+ end if;
+
+ -- If either subtype is not static, the predicates are not compatible
+
+ else
+ return False;
+ end if;
+ end Predicates_Compatible;
+
----------------------
-- Predicates_Match --
----------------------
@@ -5885,9 +5963,19 @@ package body Sem_Eval is
Formal_Derived_Matching : Boolean := False) return Boolean
is
begin
+ -- A type is always statically compatible with itself
+
+ if T1 = T2 then
+ return True;
+
+ -- Not compatible if predicates are not compatible
+
+ elsif not Predicates_Compatible (T1, T2) then
+ return False;
+
-- Scalar types
- if Is_Scalar_Type (T1) then
+ elsif Is_Scalar_Type (T1) then
-- Definitely compatible if we match
--- gcc/ada/sem_eval.ads
+++ gcc/ada/sem_eval.ads
@@ -481,6 +481,12 @@ package Sem_Eval is
-- it cannot (because the value of Lo or Hi is not known at compile time)
-- then it returns False.
+ function Predicates_Compatible (T1, T2 : Entity_Id) return Boolean;
+ -- In Ada 2012, subtypes are statically compatible if the predicates are
+ -- compatible as well. This function performs the required check that
+ -- predicates are compatible. Split from Subtypes_Statically_Compatible
+ -- so that it can be used in specializing error messages.
+
function Predicates_Match (T1, T2 : Entity_Id) return Boolean;
-- In Ada 2012, subtypes statically match if their predicates match as
-- as well. This function performs the required check that predicates
