From 4269edf01cc14cd15853692d966daf2fb92e2adc Mon Sep 17 00:00:00 2001 From: Arnaud Charlet Date: Wed, 6 Sep 2017 14:58:27 +0200 Subject: [PATCH] [multiple changes] 2017-09-06 Ed Schonberg * checks.adb (Apply_Predicate_Check): If the expression is an aggregate that is the RHS of an assignment, apply the check to the LHS after the assignment, rather than to the aggregate. This is more efficient than creating a temporary for the aggregate, and prevents back-end crashes when the aggregate includes a dynamic "others' association. 2017-09-06 Yannick Moy * sem_ch12.adb (Analyze_Instance_And_Renamings): Set variable to ignore SPARK_Mode in instance before the analysis of the generated package declaration. 2017-09-06 Yannick Moy * sem_res.adb (Resolve_Call): Do not issue a message for calls inside expression function, unless body was seen and is candidate for inlining. 2017-09-06 Ed Schonberg * sem_aux.adb (Is_Generic_Formal): Handle properly formal packages. * sem_ch3.adb (Analyze_Declarations): In a generic subprogram body. do not freeze the formals of the generic unit. 2017-09-06 Gary Dismukes * errout.adb (Error_Msg): Separate the treatment for warning vs. style messages in inlinings and instantiations. Prevents blowups on calls to Warn_Insertion for style messages, which should not be called in that case because Warning_Msg_Char is not set. 2017-09-06 Justin Squirek * sem_prag.adb (Check_VFA_Conflicts): Created to group all Volatile_Full_Access checks relating to other representation pragmas (Mark_Component_Or_Object): Created to centeralize the flagging of attributes for the record type component case, a pragma applied individually to a component, and the object case. (Process_Atomic_Independent_Shared_Volatile): Add propagation of certain pragmas to record components and move evaluation of VFA checks From-SVN: r251793 --- gcc/ada/ChangeLog | 47 +++++++ gcc/ada/checks.adb | 14 +++ gcc/ada/errout.adb | 14 ++- gcc/ada/sem_aux.adb | 8 +- gcc/ada/sem_ch12.adb | 9 ++ gcc/ada/sem_ch3.adb | 22 +++- gcc/ada/sem_prag.adb | 290 ++++++++++++++++++++++++++++--------------- gcc/ada/sem_res.adb | 32 +++-- 8 files changed, 315 insertions(+), 121 deletions(-) diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index 86f78c64cf8..b746bff0527 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,50 @@ +2017-09-06 Ed Schonberg + + * checks.adb (Apply_Predicate_Check): If the expression is an + aggregate that is the RHS of an assignment, apply the check to + the LHS after the assignment, rather than to the aggregate. This + is more efficient than creating a temporary for the aggregate, + and prevents back-end crashes when the aggregate includes a + dynamic "others' association. + +2017-09-06 Yannick Moy + + * sem_ch12.adb (Analyze_Instance_And_Renamings): + Set variable to ignore SPARK_Mode in instance before the analysis + of the generated package declaration. + +2017-09-06 Yannick Moy + + * sem_res.adb (Resolve_Call): Do not issue a + message for calls inside expression function, unless body was + seen and is candidate for inlining. + +2017-09-06 Ed Schonberg + + * sem_aux.adb (Is_Generic_Formal): Handle properly formal packages. + * sem_ch3.adb (Analyze_Declarations): In a generic subprogram + body. do not freeze the formals of the generic unit. + +2017-09-06 Gary Dismukes + + * errout.adb (Error_Msg): Separate the + treatment for warning vs. style messages in inlinings and + instantiations. Prevents blowups on calls to Warn_Insertion for + style messages, which should not be called in that case because + Warning_Msg_Char is not set. + +2017-09-06 Justin Squirek + + * sem_prag.adb (Check_VFA_Conflicts): Created + to group all Volatile_Full_Access checks relating to other + representation pragmas (Mark_Component_Or_Object): Created + to centeralize the flagging of attributes for the record type + component case, a pragma applied individually to a component, and + the object case. + (Process_Atomic_Independent_Shared_Volatile): + Add propagation of certain pragmas to record components and move + evaluation of VFA checks + 2017-09-06 Ed Schonberg * sem_prag.adb (Check_Postcondition_Use_In_Inlined_Subprogram): diff --git a/gcc/ada/checks.adb b/gcc/ada/checks.adb index 57518851322..7962b7b47df 100644 --- a/gcc/ada/checks.adb +++ b/gcc/ada/checks.adb @@ -2711,6 +2711,20 @@ package body Checks is -- it. We disable checks during its analysis, to prevent an -- infinite recursion. + -- If the prefix is an aggregate in an assignment, apply the + -- check to the LHS after assignment, rather than create a + -- redundant temporary. This is only necessary in rare cases + -- of array types (including strings) initialized with an + -- aggregate with an "others" clause, either coming from source + -- or generated by an Initialize_Scalars pragma. + + elsif Nkind (N) = N_Aggregate + and then Nkind (Parent (N)) = N_Assignment_Statement + then + Insert_Action_After (Parent (N), + Make_Predicate_Check + (Typ, Duplicate_Subexpr (Name (Parent (N))))); + else Insert_Action (N, Make_Predicate_Check diff --git a/gcc/ada/errout.adb b/gcc/ada/errout.adb index 762ccda9285..a83d0c9225e 100644 --- a/gcc/ada/errout.adb +++ b/gcc/ada/errout.adb @@ -503,11 +503,16 @@ package body Errout is ("info: in inlined body #", Actual_Error_Loc, Flag_Location, Msg_Cont_Status); - elsif Is_Warning_Msg or Is_Style_Msg then + elsif Is_Warning_Msg then Error_Msg_Internal (Warn_Insertion & "in inlined body #", Actual_Error_Loc, Flag_Location, Msg_Cont_Status); + elsif Is_Style_Msg then + Error_Msg_Internal + ("style: in inlined body #", + Actual_Error_Loc, Flag_Location, Msg_Cont_Status); + else Error_Msg_Internal ("error in inlined body #", @@ -522,11 +527,16 @@ package body Errout is ("info: in instantiation #", Actual_Error_Loc, Flag_Location, Msg_Cont_Status); - elsif Is_Warning_Msg or else Is_Style_Msg then + elsif Is_Warning_Msg then Error_Msg_Internal (Warn_Insertion & "in instantiation #", Actual_Error_Loc, Flag_Location, Msg_Cont_Status); + elsif Is_Style_Msg then + Error_Msg_Internal + ("style: in instantiation #", + Actual_Error_Loc, Flag_Location, Msg_Cont_Status); + else Error_Msg_Internal ("instantiation error #", diff --git a/gcc/ada/sem_aux.adb b/gcc/ada/sem_aux.adb index 4cb272e209c..7d0fe3babdb 100644 --- a/gcc/ada/sem_aux.adb +++ b/gcc/ada/sem_aux.adb @@ -1053,9 +1053,13 @@ package body Sem_Aux is return Nkind_In (Kind, N_Formal_Object_Declaration, - N_Formal_Package_Declaration, N_Formal_Type_Declaration) - or else Is_Formal_Subprogram (E); + or else Is_Formal_Subprogram (E) + + or else + (Ekind (E) = E_Package + and then Nkind (Original_Node (Unit_Declaration_Node (E))) = + N_Formal_Package_Declaration); end if; end Is_Generic_Formal; diff --git a/gcc/ada/sem_ch12.adb b/gcc/ada/sem_ch12.adb index 3635319884b..fdf45db0a92 100644 --- a/gcc/ada/sem_ch12.adb +++ b/gcc/ada/sem_ch12.adb @@ -5089,6 +5089,15 @@ package body Sem_Ch12 is Set_Parent_Spec (Pack_Decl, Parent_Spec (N)); end if; + -- If the context of the instance is subject to SPARK_Mode "off" or + -- the annotation is altogether missing, set the global flag which + -- signals Analyze_Pragma to ignore all SPARK_Mode pragmas within + -- the instance. + + if SPARK_Mode /= On then + Ignore_SPARK_Mode_Pragmas_In_Instance := True; + end if; + Analyze (Pack_Decl); Check_Formal_Packages (Pack_Id); Set_Is_Generic_Instance (Pack_Id, False); diff --git a/gcc/ada/sem_ch3.adb b/gcc/ada/sem_ch3.adb index bda8fae37c6..958e733cf57 100644 --- a/gcc/ada/sem_ch3.adb +++ b/gcc/ada/sem_ch3.adb @@ -2649,8 +2649,26 @@ package body Sem_Ch3 is -- in order to perform visibility checks on delayed aspects. Adjust_Decl; - Freeze_All (First_Entity (Current_Scope), Decl); - Freeze_From := Last_Entity (Current_Scope); + + -- If the current scope is a generic subprogram body. skip + -- the generic formal parameters that are not frozen here. + + if Is_Subprogram (Current_Scope) + and then Nkind (Unit_Declaration_Node (Current_Scope)) + = N_Generic_Subprogram_Declaration + and then Present (First_Entity (Current_Scope)) + then + while Is_Generic_Formal (Freeze_From) loop + Freeze_From := Next_Entity (Freeze_From); + end loop; + + Freeze_All (Freeze_From, Decl); + Freeze_From := Last_Entity (Current_Scope); + + else + Freeze_All (First_Entity (Current_Scope), Decl); + Freeze_From := Last_Entity (Current_Scope); + end if; -- Current scope is a package specification diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index 91bcf944a0e..692975b5fd7 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -6873,26 +6873,193 @@ package body Sem_Prag is ------------------------------------------------ procedure Process_Atomic_Independent_Shared_Volatile is - procedure Set_Atomic_VFA (E : Entity_Id); + procedure Check_VFA_Conflicts (Ent : Entity_Id); + -- Apply additional checks for the GNAT pragma Volatile_Full_Access + + procedure Mark_Component_Or_Object (Ent : Entity_Id); + -- Appropriately set flags on the given entity (either an array or + -- record component, or an object declaration) according to the + -- current pragma. + + procedure Set_Atomic_VFA (Ent : Entity_Id); -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if -- no explicit alignment was given, set alignment to unknown, since -- back end knows what the alignment requirements are for atomic and -- full access arrays. Note: this is necessary for derived types. + ------------------------- + -- Check_VFA_Conflicts -- + ------------------------- + + procedure Check_VFA_Conflicts (Ent : Entity_Id) is + Comp : Entity_Id; + Typ : Entity_Id; + + VFA_And_Atomic : Boolean := False; + -- Set True if atomic component present + + VFA_And_Aliased : Boolean := False; + -- Set True if aliased component present + + begin + -- Fetch the type in case we are dealing with an object or + -- component. + + if Is_Type (Ent) then + Typ := Ent; + else + pragma Assert (Is_Object (Ent) + or else + Nkind (Declaration_Node (Ent)) = N_Component_Declaration); + + Typ := Etype (Ent); + end if; + + -- Check Atomic and VFA used together + + if Prag_Id = Pragma_Volatile_Full_Access + or else Is_Volatile_Full_Access (Ent) + then + if Prag_Id = Pragma_Atomic + or else Prag_Id = Pragma_Shared + or else Is_Atomic (Ent) + then + VFA_And_Atomic := True; + + elsif Is_Array_Type (Typ) then + VFA_And_Atomic := Has_Atomic_Components (Typ); + + -- Note: Has_Atomic_Components is not used below, as this flag + -- represents the pragma of the same name, Atomic_Components, + -- which only applies to arrays. + + elsif Is_Record_Type (Typ) then + -- Attributes cannot be applied to discriminants, only + -- regular record components. + + Comp := First_Component (Typ); + while Present (Comp) loop + if Is_Atomic (Comp) + or else Is_Atomic (Typ) + then + VFA_And_Atomic := True; + + exit; + end if; + + Next_Component (Comp); + end loop; + end if; + + if VFA_And_Atomic then + Error_Pragma + ("cannot have Volatile_Full_Access and Atomic for same " + & "entity"); + end if; + end if; + + -- Check for the application of VFA to an entity that has aliased + -- components. + + if Prag_Id = Pragma_Volatile_Full_Access then + if Is_Array_Type (Typ) + and then Has_Aliased_Components (Typ) + then + VFA_And_Aliased := True; + + -- Note: Has_Aliased_Components, like Has_Atomic_Components, + -- and Has_Independent_Components, applies only to arrays. + -- However, this flag does not have a corresponding pragma, so + -- perhaps it should be possible to apply it to record types as + -- well. Should this be done ??? + + elsif Is_Record_Type (Typ) then + -- It is possible to have an aliased discriminant, so they + -- must be checked along with normal components. + + Comp := First_Component_Or_Discriminant (Typ); + while Present (Comp) loop + if Is_Aliased (Comp) + or else Is_Aliased (Etype (Comp)) + then + VFA_And_Aliased := True; + Check_SPARK_05_Restriction + ("aliased is not allowed", Comp); + + exit; + end if; + + Next_Component_Or_Discriminant (Comp); + end loop; + end if; + + if VFA_And_Aliased then + Error_Pragma + ("cannot apply Volatile_Full_Access (aliased component " + & "present)"); + end if; + end if; + end Check_VFA_Conflicts; + + ------------------------------ + -- Mark_Component_Or_Object -- + ------------------------------ + + procedure Mark_Component_Or_Object (Ent : Entity_Id) is + begin + if Prag_Id = Pragma_Atomic + or else Prag_Id = Pragma_Shared + or else Prag_Id = Pragma_Volatile_Full_Access + then + if Prag_Id = Pragma_Volatile_Full_Access then + Set_Is_Volatile_Full_Access (Ent); + else + Set_Is_Atomic (Ent); + end if; + + -- If the object declaration has an explicit initialization, a + -- temporary may have to be created to hold the expression, to + -- ensure that access to the object remains atomic. + + if Nkind (Parent (Ent)) = N_Object_Declaration + and then Present (Expression (Parent (Ent))) + then + Set_Has_Delayed_Freeze (Ent); + end if; + end if; + + -- Atomic/Shared/Volatile_Full_Access imply Independent + + if Prag_Id /= Pragma_Volatile then + Set_Is_Independent (Ent); + + if Prag_Id = Pragma_Independent then + Record_Independence_Check (N, Ent); + end if; + end if; + + -- Atomic/Shared/Volatile_Full_Access imply Volatile + + if Prag_Id /= Pragma_Independent then + Set_Is_Volatile (Ent); + Set_Treat_As_Volatile (Ent); + end if; + end Mark_Component_Or_Object; + -------------------- -- Set_Atomic_VFA -- -------------------- - procedure Set_Atomic_VFA (E : Entity_Id) is + procedure Set_Atomic_VFA (Ent : Entity_Id) is begin if Prag_Id = Pragma_Volatile_Full_Access then - Set_Is_Volatile_Full_Access (E); + Set_Is_Volatile_Full_Access (Ent); else - Set_Is_Atomic (E); + Set_Is_Atomic (Ent); end if; - if not Has_Alignment_Clause (E) then - Set_Alignment (E, Uint_0); + if not Has_Alignment_Clause (Ent) then + Set_Alignment (Ent, Uint_0); end if; end Set_Atomic_VFA; @@ -6926,63 +7093,15 @@ package body Sem_Prag is Check_Duplicate_Pragma (E); - -- Check Atomic and VFA used together - - if (Is_Atomic (E) and then Prag_Id = Pragma_Volatile_Full_Access) - or else (Is_Volatile_Full_Access (E) - and then (Prag_Id = Pragma_Atomic - or else - Prag_Id = Pragma_Shared)) - then - Error_Pragma - ("cannot have Volatile_Full_Access and Atomic for same entity"); - end if; - - -- Check for applying VFA to an entity which has aliased component - - if Prag_Id = Pragma_Volatile_Full_Access then - declare - Comp : Entity_Id; - Aliased_Comp : Boolean := False; - -- Set True if aliased component present - - begin - if Is_Array_Type (Etype (E)) then - Aliased_Comp := Has_Aliased_Components (Etype (E)); - - -- Record case, too bad Has_Aliased_Components is not also - -- set for records, should it be ??? - - elsif Is_Record_Type (Etype (E)) then - Comp := First_Component_Or_Discriminant (Etype (E)); - while Present (Comp) loop - if Is_Aliased (Comp) - or else Is_Aliased (Etype (Comp)) - then - Aliased_Comp := True; - exit; - end if; - - Next_Component_Or_Discriminant (Comp); - end loop; - end if; - - if Aliased_Comp then - Error_Pragma - ("cannot apply Volatile_Full_Access (aliased component " - & "present)"); - end if; - end; - end if; - - -- Now check appropriateness of the entity + -- Check appropriateness of the entity Decl := Declaration_Node (E); + -- Deal with the case where the pragma/attribute is applied to a type + if Is_Type (E) then if Rep_Item_Too_Early (E, N) - or else - Rep_Item_Too_Late (E, N) + or else Rep_Item_Too_Late (E, N) then return; else @@ -6993,10 +7112,8 @@ package body Sem_Prag is -- currently private, it also belongs on the underlying type. if Prag_Id = Pragma_Atomic - or else - Prag_Id = Pragma_Shared - or else - Prag_Id = Pragma_Volatile_Full_Access + or else Prag_Id = Pragma_Shared + or else Prag_Id = Pragma_Volatile_Full_Access then Set_Atomic_VFA (E); Set_Atomic_VFA (Base_Type (E)); @@ -7026,6 +7143,9 @@ package body Sem_Prag is Set_Treat_As_Volatile (Underlying_Type (E)); end if; + -- Deal with the case where the pragma/attribute applies to a + -- component or object declaration. + elsif Nkind (Decl) = N_Object_Declaration or else (Nkind (Decl) = N_Component_Declaration and then Original_Record_Component (E) = E) @@ -7034,50 +7154,16 @@ package body Sem_Prag is return; end if; - if Prag_Id = Pragma_Atomic - or else - Prag_Id = Pragma_Shared - or else - Prag_Id = Pragma_Volatile_Full_Access - then - if Prag_Id = Pragma_Volatile_Full_Access then - Set_Is_Volatile_Full_Access (E); - else - Set_Is_Atomic (E); - end if; - - -- If the object declaration has an explicit initialization, a - -- temporary may have to be created to hold the expression, to - -- ensure that access to the object remain atomic. - - if Nkind (Parent (E)) = N_Object_Declaration - and then Present (Expression (Parent (E))) - then - Set_Has_Delayed_Freeze (E); - end if; - end if; - - -- Atomic/Shared/Volatile_Full_Access imply Independent - - if Prag_Id /= Pragma_Volatile then - Set_Is_Independent (E); - - if Prag_Id = Pragma_Independent then - Record_Independence_Check (N, E); - end if; - end if; - - -- Atomic/Shared/Volatile_Full_Access imply Volatile - - if Prag_Id /= Pragma_Independent then - Set_Is_Volatile (E); - Set_Treat_As_Volatile (E); - end if; - + Mark_Component_Or_Object (E); else Error_Pragma_Arg ("inappropriate entity for pragma%", Arg1); end if; + -- Perform the checks needed to assure the proper use of the GNAT + -- pragma Volatile_Full_Access. + + Check_VFA_Conflicts (E); + -- The following check is only relevant when SPARK_Mode is on as -- this is not a standard Ada legality rule. Pragma Volatile can -- only apply to a full type declaration or an object declaration diff --git a/gcc/ada/sem_res.adb b/gcc/ada/sem_res.adb index 28713c23d68..eef4016ac7c 100644 --- a/gcc/ada/sem_res.adb +++ b/gcc/ada/sem_res.adb @@ -6657,10 +6657,28 @@ package body Sem_Res is elsif Full_Analysis then + -- Do not inline calls inside expression functions, as this + -- would prevent interpreting them as logical formulas in + -- GNATprove. Only issue a message when the body has been seen, + -- otherwise this leads to spurious messages on callees that + -- are themselves expression functions. + + if Present (Current_Subprogram) + and then + Is_Expression_Function_Or_Completion (Current_Subprogram) + then + if Present (Body_Id) + and then Present (Body_To_Inline (Nam_Decl)) + then + Cannot_Inline + ("cannot inline & (inside expression function)?", + N, Nam_UA); + end if; + -- With the one-pass inlining technique, a call cannot be -- inlined if the corresponding body has not been seen yet. - if No (Body_Id) then + elsif No (Body_Id) then Cannot_Inline ("cannot inline & (body not seen yet)?", N, Nam_UA); @@ -6671,18 +6689,6 @@ package body Sem_Res is elsif No (Body_To_Inline (Nam_Decl)) then null; - -- Do not inline calls inside expression functions, as this - -- would prevent interpreting them as logical formulas in - -- GNATprove. - - elsif Present (Current_Subprogram) - and then - Is_Expression_Function_Or_Completion (Current_Subprogram) - then - Cannot_Inline - ("cannot inline & (inside expression function)?", - N, Nam_UA); - -- Calls cannot be inlined inside potentially unevaluated -- expressions, as this would create complex actions inside -- expressions, that are not handled by GNATprove. -- 2.30.2