[gcc/devel/c++-modules] [Ada] Implement AI12-0351 Matching for actuals for formal derived types
Nathan Sidwell
nathan@gcc.gnu.org
Thu Jun 25 19:16:35 GMT 2020
https://gcc.gnu.org/g:0faf0503312ddf6bfc88cecfa1adcd903b20b97c
commit 0faf0503312ddf6bfc88cecfa1adcd903b20b97c
Author: Eric Botcazou <ebotcazou@adacore.com>
Date: Fri Apr 3 12:37:45 2020 +0200
[Ada] Implement AI12-0351 Matching for actuals for formal derived types
2020-06-16 Eric Botcazou <ebotcazou@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.
Diff:
---
gcc/ada/sem_ch12.adb | 12 +++++--
gcc/ada/sem_ch3.adb | 95 +++++++++++++++++++++++++++++-----------------------
gcc/ada/sem_eval.adb | 90 ++++++++++++++++++++++++++++++++++++++++++++++++-
gcc/ada/sem_eval.ads | 6 ++++
4 files changed, 158 insertions(+), 45 deletions(-)
diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb
index 8972bedae82..2240b7e24d2 100644
--- a/gcc/ada/sem_ch12.adb
+++ b/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;
diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb
index 149776c212a..ce9ea0af74e 100644
--- a/gcc/ada/sem_ch3.adb
+++ b/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 --
------------------------------------
diff --git a/gcc/ada/sem_eval.adb b/gcc/ada/sem_eval.adb
index 85a819bf075..74eebb80e58 100644
--- a/gcc/ada/sem_eval.adb
+++ b/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
diff --git a/gcc/ada/sem_eval.ads b/gcc/ada/sem_eval.ads
index 3bdbd4b177c..6f2c8d4a263 100644
--- a/gcc/ada/sem_eval.ads
+++ b/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
More information about the Gcc-cvs
mailing list