From 0faf0503312ddf6bfc88cecfa1adcd903b20b97c Mon Sep 17 00:00:00 2001 From: Eric Botcazou Date: Fri, 3 Apr 2020 12:37:45 +0200 Subject: [PATCH] [Ada] Implement AI12-0351 Matching for actuals for formal derived types 2020-06-16 Eric Botcazou 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 | 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 -- 2.30.2