From c468e1fba8516aa0029733406c00074c752f0aee Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Fri, 8 Sep 2017 11:48:16 +0200 Subject: [PATCH] [multiple changes] 2017-09-08 Yannick Moy * sem_prag.adb (Analyze_Pragma): Issue more precise error messages on Loop_Variant. 2017-09-08 Ed Schonberg * exp_attr.adb (Build_Record_VS_Func): If the record is an unchecked union, do not emit checks for its (non-existent) discriminants, or for variant parts that depend on them. 2017-09-08 Justin Squirek * sem_ch4.adb (Find_Equality_Types.Try_One_Interp, Find_Comparison_Type.Try_One_Interp): Add check for generic instances. From-SVN: r251878 --- gcc/ada/ChangeLog | 17 +++++++++++++++++ gcc/ada/exp_attr.adb | 13 ++++++++++++- gcc/ada/sem_ch4.adb | 18 +++++++++++++++--- gcc/ada/sem_prag.adb | 36 +++++++++++++++++++++++++++++++++--- 4 files changed, 77 insertions(+), 7 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 5ce59b4df03..97a59e422b3 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,20 @@ +2017-09-08 Yannick Moy + + * sem_prag.adb (Analyze_Pragma): Issue more precise error messages on + Loop_Variant. + +2017-09-08 Ed Schonberg + + * exp_attr.adb (Build_Record_VS_Func): If the record is an + unchecked union, do not emit checks for its (non-existent) + discriminants, or for variant parts that depend on them. + +2017-09-08 Justin Squirek + + * sem_ch4.adb (Find_Equality_Types.Try_One_Interp, + Find_Comparison_Type.Try_One_Interp): Add check for generic + instances. + 2017-09-08 Arnaud Charlet * sem_ch3.adb, layout.adb, layout.ads, exp_attr.adb, debug.adb, diff --git a/gcc/ada/exp_attr.adb b/gcc/ada/exp_attr.adb index 76b99e89c91..ebd55d8b528 100644 --- a/gcc/ada/exp_attr.adb +++ b/gcc/ada/exp_attr.adb @@ -423,6 +423,10 @@ package body Exp_Attr is -- return True; -- end _Valid_Scalars; + -- If the record type is an unchecked union, we can only check components + -- in the invariant part, given that there are no discriminant values to + -- select a variant. + function Build_Record_VS_Func (R_Type : Entity_Id; Nod : Node_Id) return Entity_Id @@ -475,7 +479,9 @@ package body Exp_Attr is begin Append_To (Result, Make_VS_If (E, Component_Items (CL))); - if No (Variant_Part (CL)) then + if No (Variant_Part (CL)) + or else Is_Unchecked_Union (R_Type) + then return Result; end if; @@ -564,6 +570,11 @@ package body Exp_Attr is elsif Field_Name = Name_uTag then null; + elsif Ekind (Def_Id) = E_Discriminant + and then Is_Unchecked_Union (R_Type) + then + null; + -- Don't bother with component with no scalar components elsif not Scalar_Part_Present (Etype (Def_Id)) then diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index b02d72bc509..7cdf9e8ea67 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -6287,10 +6287,16 @@ package body Sem_Ch4 is -- If the operator is an expanded name, then the type of the operand -- must be defined in the corresponding scope. If the type is - -- universal, the context will impose the correct type. + -- universal, the context will impose the correct type. Note that we + -- also avoid returning if we are currently within a generic instance + -- due to the fact that the generic package declaration has already + -- been successfully analyzed and Defined_In_Scope expects the base + -- type to be defined within the instance which will never be the + -- case. if Present (Scop) and then not Defined_In_Scope (T1, Scop) + and then not In_Instance and then T1 /= Universal_Integer and then T1 /= Universal_Real and then T1 /= Any_String @@ -6311,7 +6317,6 @@ package body Sem_Ch4 is else T_F := It.Typ; end if; - else Found := True; T_F := T1; @@ -6320,7 +6325,6 @@ package body Sem_Ch4 is Set_Etype (L, T_F); Find_Non_Universal_Interpretations (N, R, Op_Id, T1); - end if; end Try_One_Interp; @@ -6472,7 +6476,15 @@ package body Sem_Ch4 is -- is declared in Standard, and preference rules apply to it. if Present (Scop) then + + -- Note that we avoid returning if we are currently within a + -- generic instance due to the fact that the generic package + -- declaration has already been successfully analyzed and + -- Defined_In_Scope expects the base type to be defined within the + -- instance which will never be the case. + if Defined_In_Scope (T1, Scop) + or else In_Instance or else T1 = Universal_Integer or else T1 = Universal_Real or else T1 = Any_Access diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 4d1e2b0a199..373fcdad1b9 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -17916,10 +17916,40 @@ package body Sem_Prag is Variant := First (Pragma_Argument_Associations (N)); while Present (Variant) loop - if not Nam_In (Chars (Variant), Name_Decreases, - Name_Increases) + if Chars (Variant) = No_Name then + Error_Pragma_Arg ("expect name `Increases`", Variant); + + elsif not Nam_In (Chars (Variant), Name_Decreases, + Name_Increases) then - Error_Pragma_Arg ("wrong change modifier", Variant); + declare + Name : constant String := + Get_Name_String (Chars (Variant)); + begin + -- It is a common mistake to write "Increasing" for + -- "Increases" or "Decreasing" for "Decreases". Recognize + -- specially names starting with "Incr" or "Decr" to + -- suggest the corresponding name. + + if Name'Length >= 4 + and then (Name (1 .. 4) = "Incr" + or else Name (1 .. 4) = "incr") + then + Error_Pragma_Arg_Ident + ("expect name `Increases`", Variant); + + elsif Name'Length >= 4 + and then (Name (1 .. 4) = "Decr" + or else Name (1 .. 4) = "decr") + then + Error_Pragma_Arg_Ident + ("expect name `Decreases`", Variant); + + else + Error_Pragma_Arg_Ident + ("expect name `Increases` or `Decreases`", Variant); + end if; + end; end if; Preanalyze_Assert_Expression -- 2.30.2