From: Arnaud Charlet Date: Wed, 27 May 2015 13:19:35 +0000 (+0200) Subject: [multiple changes] X-Git-Url: https://git.libre-soc.org/?a=commitdiff_plain;h=0c6826a52305c4dadad3da2882f708e80638f100;p=gcc.git [multiple changes] 2015-05-26 Robert Dewar * errout.ads, sem_ch4.adb, sem_ch6.adb: Minor reformatting. 2015-05-26 Bob Duff * sem_elab.adb (Check_A_Call): In the case where we're calling something in an instance of a generic package that is within this same unit (as the call), make sure we treat it as a call to an entity within the same unit. That is, call Check_Internal_Call, rather than putting "Elaborate_All(X)" on X, which would necessarily result in an elaboration cycle in static-elaboration mode. 2015-05-26 Eric Botcazou * freeze.ads (Is_Atomic_VFA_Aggregate): Adjust profile. * freeze.adb (Is_Atomic_VFA_Aggregate): Change Entity parameter into Node parameter and remove Type parameter. Look at Is_Atomic_Or_VFA both on the type and on the object. (Freeze_Entity): Adjust call to Is_Atomic_VFA_Aggregate. * exp_aggr.adb (Expand_Record_Aggregate): Likewise. (Process_Atomic_Independent_Shared_Volatile): Remove code propagating Atomic or VFA from object to locally-defined type. 2015-05-26 Bob Duff * exp_ch7.adb: Minor comment fix. From-SVN: r223751 --- diff --git a/gcc/ada/ChangeLog b/gcc/ada/ChangeLog index b6e11e1cbbc..0bce664d3d2 100644 --- a/gcc/ada/ChangeLog +++ b/gcc/ada/ChangeLog @@ -1,3 +1,32 @@ +2015-05-26 Robert Dewar + + * errout.ads, sem_ch4.adb, sem_ch6.adb: Minor reformatting. + +2015-05-26 Bob Duff + + * sem_elab.adb (Check_A_Call): In the case where we're + calling something in an instance of a generic package that is + within this same unit (as the call), make sure we treat it + as a call to an entity within the same unit. That is, call + Check_Internal_Call, rather than putting "Elaborate_All(X)" + on X, which would necessarily result in an elaboration cycle in + static-elaboration mode. + +2015-05-26 Eric Botcazou + + * freeze.ads (Is_Atomic_VFA_Aggregate): Adjust profile. + * freeze.adb (Is_Atomic_VFA_Aggregate): Change Entity + parameter into Node parameter and remove Type parameter. + Look at Is_Atomic_Or_VFA both on the type and on the object. + (Freeze_Entity): Adjust call to Is_Atomic_VFA_Aggregate. + * exp_aggr.adb (Expand_Record_Aggregate): Likewise. + (Process_Atomic_Independent_Shared_Volatile): Remove code + propagating Atomic or VFA from object to locally-defined type. + +2015-05-26 Bob Duff + + * exp_ch7.adb: Minor comment fix. + 2015-05-26 Eric Botcazou * gcc-interface/trans.c (Attribute_to_gnu) : Do not diff --git a/gcc/ada/errout.ads b/gcc/ada/errout.ads index 8a3f9f25f7a..1832b0d6359 100644 --- a/gcc/ada/errout.ads +++ b/gcc/ada/errout.ads @@ -24,7 +24,7 @@ ------------------------------------------------------------------------------ -- This package contains the routines to output error messages. They are --- basically system independent, however, in some environments, e.g. when the +-- basically system independent, however in some environments, e.g. when the -- parser is embedded into an editor, it may be appropriate to replace the -- implementation of this package. diff --git a/gcc/ada/exp_aggr.adb b/gcc/ada/exp_aggr.adb index 3e200633889..6cdd290bd9e 100644 --- a/gcc/ada/exp_aggr.adb +++ b/gcc/ada/exp_aggr.adb @@ -5950,10 +5950,7 @@ package body Exp_Aggr is -- temporary instead, so that the back end can generate an atomic move -- for it. - if Is_Atomic_Or_VFA (Typ) - and then Comes_From_Source (Parent (N)) - and then Is_Atomic_VFA_Aggregate (N, Typ) - then + if Is_Atomic_VFA_Aggregate (N) then return; -- No special management required for aggregates used to initialize diff --git a/gcc/ada/exp_ch7.adb b/gcc/ada/exp_ch7.adb index 7452146d40f..74854ba2da5 100644 --- a/gcc/ada/exp_ch7.adb +++ b/gcc/ada/exp_ch7.adb @@ -129,7 +129,7 @@ package body Exp_Ch7 is function Find_Node_To_Be_Wrapped (N : Node_Id) return Node_Id; -- N is a node which may generate a transient scope. Loop over the parent - -- pointers of N until it find the appropriate node to wrap. If it returns + -- pointers of N until we find the appropriate node to wrap. If it returns -- Empty, it means that no transient scope is needed in this context. procedure Insert_Actions_In_Scope_Around diff --git a/gcc/ada/freeze.adb b/gcc/ada/freeze.adb index fc029c9658b..c7ad86c1d41 100644 --- a/gcc/ada/freeze.adb +++ b/gcc/ada/freeze.adb @@ -1459,17 +1459,15 @@ package body Freeze is -- Is_Atomic_VFA_Aggregate -- ----------------------------- - function Is_Atomic_VFA_Aggregate - (E : Entity_Id; - Typ : Entity_Id) return Boolean - is - Loc : constant Source_Ptr := Sloc (E); + function Is_Atomic_VFA_Aggregate (N : Node_Id) return Boolean is + Loc : constant Source_Ptr := Sloc (N); New_N : Node_Id; Par : Node_Id; Temp : Entity_Id; + Typ : Entity_Id; begin - Par := Parent (E); + Par := Parent (N); -- Array may be qualified, so find outer context @@ -1477,24 +1475,45 @@ package body Freeze is Par := Parent (Par); end if; - if Nkind_In (Par, N_Object_Declaration, N_Assignment_Statement) - and then Comes_From_Source (Par) - then - Temp := Make_Temporary (Loc, 'T', E); - New_N := - Make_Object_Declaration (Loc, - Defining_Identifier => Temp, - Object_Definition => New_Occurrence_Of (Typ, Loc), - Expression => Relocate_Node (E)); - Insert_Before (Par, New_N); - Analyze (New_N); - - Set_Expression (Par, New_Occurrence_Of (Temp, Loc)); - return True; - - else + if not Comes_From_Source (Par) then return False; end if; + + case Nkind (Par) is + when N_Assignment_Statement => + Typ := Etype (Name (Par)); + + if not Is_Atomic_Or_VFA (Typ) + and then not (Is_Entity_Name (Name (Par)) + and then Is_Atomic_Or_VFA (Entity (Name (Par)))) + then + return False; + end if; + + when N_Object_Declaration => + Typ := Etype (Defining_Identifier (Par)); + + if not Is_Atomic_Or_VFA (Typ) + and then not Is_Atomic_Or_VFA (Defining_Identifier (Par)) + then + return False; + end if; + + when others => + return False; + end case; + + Temp := Make_Temporary (Loc, 'T', N); + New_N := + Make_Object_Declaration (Loc, + Defining_Identifier => Temp, + Object_Definition => New_Occurrence_Of (Typ, Loc), + Expression => Relocate_Node (N)); + Insert_Before (Par, New_N); + Analyze (New_N); + + Set_Expression (Par, New_Occurrence_Of (Temp, Loc)); + return True; end Is_Atomic_VFA_Aggregate; ----------------------------------------------- @@ -4821,8 +4840,7 @@ package body Freeze is and then Nkind (Parent (E)) = N_Object_Declaration and then Present (Expression (Parent (E))) and then Nkind (Expression (Parent (E))) = N_Aggregate - and then - Is_Atomic_VFA_Aggregate (Expression (Parent (E)), Etype (E)) + and then Is_Atomic_VFA_Aggregate (Expression (Parent (E))) then null; end if; diff --git a/gcc/ada/freeze.ads b/gcc/ada/freeze.ads index 3179e4b1412..f11347d5ed0 100644 --- a/gcc/ada/freeze.ads +++ b/gcc/ada/freeze.ads @@ -174,9 +174,7 @@ package Freeze is -- do not allow a size clause if the size would not otherwise be known at -- compile time in any case. - function Is_Atomic_VFA_Aggregate - (E : Entity_Id; - Typ : Entity_Id) return Boolean; + function Is_Atomic_VFA_Aggregate (N : Node_Id) return Boolean; -- If an atomic/VFA object is initialized with an aggregate or is assigned -- an aggregate, we have to prevent a piecemeal access or assignment to the -- object, even if the aggregate is to be expanded. We create a temporary diff --git a/gcc/ada/sem_ch4.adb b/gcc/ada/sem_ch4.adb index 1c0dbd9b723..b525e90a098 100644 --- a/gcc/ada/sem_ch4.adb +++ b/gcc/ada/sem_ch4.adb @@ -1968,10 +1968,10 @@ package body Sem_Ch4 is end if; -- An explicit dereference is a legal occurrence of an - -- incomplete type imported through a limited_with clause, - -- if the full view is visible, or if we are within an - -- instance body, where the enclosing body has a regular - -- with_clause on the unit. + -- incomplete type imported through a limited_with clause, if + -- the full view is visible, or if we are within an instance + -- body, where the enclosing body has a regular with_clause + -- on the unit. if From_Limited_With (DT) and then not From_Limited_With (Scope (DT)) @@ -2196,8 +2196,8 @@ package body Sem_Ch4 is Get_First_Interp (Then_Expr, I, It); while Present (It.Nam) loop - -- Add possible intepretation of Then_Expr if no Else_Expr, - -- or Else_Expr is present and has a compatible type. + -- Add possible intepretation of Then_Expr if no Else_Expr, or + -- Else_Expr is present and has a compatible type. if No (Else_Expr) or else Has_Compatible_Type (Else_Expr, It.Typ) @@ -2224,8 +2224,8 @@ package body Sem_Ch4 is U_N : Entity_Id; procedure Process_Function_Call; - -- Prefix in indexed component form is an overloadable entity, - -- so the node is a function call. Reformat it as such. + -- Prefix in indexed component form is an overloadable entity, so the + -- node is a function call. Reformat it as such. procedure Process_Indexed_Component; -- Prefix in indexed component form is actually an indexed component. @@ -2263,8 +2263,8 @@ package body Sem_Ch4 is -- Move to next actual. Note that we use Next, not Next_Actual -- here. The reason for this is a bit subtle. If a function call - -- includes named associations, the parser recognizes the node as - -- a call, and it is analyzed as such. If all associations are + -- includes named associations, the parser recognizes the node + -- as a call, and it is analyzed as such. If all associations are -- positional, the parser builds an indexed_component node, and -- it is only after analysis of the prefix that the construct -- is recognized as a call, in which case Process_Function_Call @@ -2398,7 +2398,7 @@ package body Sem_Ch4 is elsif Is_Entity_Name (P) and then Etype (P) = Standard_Void_Type then - Error_Msg_NE ("incorrect use of&", P, Entity (P)); + Error_Msg_NE ("incorrect use of &", P, Entity (P)); else Error_Msg_N ("array type required in indexed component", P); @@ -2447,10 +2447,10 @@ package body Sem_Ch4 is Exp := First (Exprs); - -- If one index is present, and it is a subtype name, then the - -- node denotes a slice (note that the case of an explicit range - -- for a slice was already built as an N_Slice node in the first - -- place, so that case is not handled here). + -- If one index is present, and it is a subtype name, then the node + -- denotes a slice (note that the case of an explicit range for a + -- slice was already built as an N_Slice node in the first place, + -- so that case is not handled here). -- We use a replace rather than a rewrite here because this is one -- of the cases in which the tree built by the parser is plain wrong. diff --git a/gcc/ada/sem_ch6.adb b/gcc/ada/sem_ch6.adb index fdfe9f6a504..43cbffce8be 100644 --- a/gcc/ada/sem_ch6.adb +++ b/gcc/ada/sem_ch6.adb @@ -8297,7 +8297,7 @@ package body Sem_Ch6 is then Defn := Type_Definition - (Original_Node (Parent (First_Subtype (F_Typ)))); + (Original_Node (Parent (First_Subtype (F_Typ)))); else Defn := Type_Definition (Original_Node (Parent (F_Typ))); end if; @@ -8347,6 +8347,7 @@ package body Sem_Ch6 is elsif not Is_Class_Wide_Type (New_Type) then while Etype (New_Type) /= New_Type loop New_Type := Etype (New_Type); + if New_Type = Prev_Type then return True; end if; diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index 9e514c17411..07517bbc467 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -736,407 +736,405 @@ package body Sem_Elab is return; end if; - -- Case of entity is not in current unit (i.e. with'ed unit case) - - if E_Scope /= C_Scope then - - -- We are only interested in such calls if the outer call was from - -- elaboration code, or if we are in Dynamic_Elaboration_Checks mode. + -- Find top level scope for called entity (not following renamings + -- or derivations). This is where the Elaborate_All will go if it is + -- needed. We start with the called entity, except in the case of an + -- initialization procedure outside the current package, where the init + -- proc is in the root package, and we start from the entity of the name + -- in the call. - if not From_Elab_Code and then not Dynamic_Elaboration_Checks then - return; + declare + Ent : constant Entity_Id := Get_Referenced_Ent (N); + begin + if Is_Init_Proc (Ent) + and then not In_Same_Extended_Unit (N, Ent) + then + W_Scope := Scope (Ent); + else + W_Scope := E; end if; + end; - -- Nothing to do if some scope said that no checks were required + -- Now loop through scopes to get to the enclosing compilation unit - if Cunit_SC then - return; - end if; + while not Is_Compilation_Unit (W_Scope) loop + W_Scope := Scope (W_Scope); + end loop; - -- Nothing to do for a generic instance, because in this case the - -- checking was at the point of instantiation of the generic However, - -- this shortcut is only applicable in static mode. + -- Case of entity is in same unit as call or instantiation. In the + -- instantiation case, W_Scope may be different from E_Scope; we want + -- the unit in which the instantiation occurs, since we're analyzing + -- based on the expansion. - if Is_Generic_Instance (Ent) and not Dynamic_Elaboration_Checks then - return; + if W_Scope = C_Scope then + if not Inter_Unit_Only then + Check_Internal_Call (N, Ent, Outer_Scope, E); end if; - -- Nothing to do if subprogram with no separate spec. However, a - -- call to Deep_Initialize may result in a call to a user-defined - -- Initialize procedure, which imposes a body dependency. This - -- happens only if the type is controlled and the Initialize - -- procedure is not inherited. + return; + end if; - if Body_Acts_As_Spec then - if Is_TSS (Ent, TSS_Deep_Initialize) then - declare - Typ : constant Entity_Id := Etype (First_Formal (Ent)); - Init : Entity_Id; + -- Case of entity is not in current unit (i.e. with'ed unit case) - begin - if not Is_Controlled (Typ) then - return; - else - Init := Find_Prim_Op (Typ, Name_Initialize); + -- We are only interested in such calls if the outer call was from + -- elaboration code, or if we are in Dynamic_Elaboration_Checks mode. - if Comes_From_Source (Init) then - Ent := Init; - else - return; - end if; - end if; - end; - - else - return; - end if; - end if; + if not From_Elab_Code and then not Dynamic_Elaboration_Checks then + return; + end if; - -- Check cases of internal units + -- Nothing to do if some scope said that no checks were required - Callee_Unit_Internal := - Is_Internal_File_Name - (Unit_File_Name (Get_Source_Unit (E_Scope))); + if Cunit_SC then + return; + end if; - -- Do not give a warning if the with'ed unit is internal and this is - -- the generic instantiation case (this saves a lot of hassle dealing - -- with the Text_IO special child units) + -- Nothing to do for a generic instance, because in this case the + -- checking was at the point of instantiation of the generic However, + -- this shortcut is only applicable in static mode. - if Callee_Unit_Internal and Inst_Case then - return; - end if; + if Is_Generic_Instance (Ent) and not Dynamic_Elaboration_Checks then + return; + end if; - if C_Scope = Standard_Standard then - Caller_Unit_Internal := False; - else - Caller_Unit_Internal := - Is_Internal_File_Name - (Unit_File_Name (Get_Source_Unit (C_Scope))); - end if; + -- Nothing to do if subprogram with no separate spec. However, a call + -- to Deep_Initialize may result in a call to a user-defined Initialize + -- procedure, which imposes a body dependency. This happens only if the + -- type is controlled and the Initialize procedure is not inherited. - -- Do not give a warning if the with'ed unit is internal and the - -- caller is not internal (since the binder always elaborates - -- internal units first). + if Body_Acts_As_Spec then + if Is_TSS (Ent, TSS_Deep_Initialize) then + declare + Typ : constant Entity_Id := Etype (First_Formal (Ent)); + Init : Entity_Id; - if Callee_Unit_Internal and (not Caller_Unit_Internal) then - return; - end if; + begin + if not Is_Controlled (Typ) then + return; + else + Init := Find_Prim_Op (Typ, Name_Initialize); - -- For now, if debug flag -gnatdE is not set, do no checking for - -- one internal unit withing another. This fixes the problem with - -- the sgi build and storage errors. To be resolved later ??? + if Comes_From_Source (Init) then + Ent := Init; + else + return; + end if; + end if; + end; - if (Callee_Unit_Internal and Caller_Unit_Internal) - and then not Debug_Flag_EE - then + else return; end if; + end if; - if Is_TSS (E, TSS_Deep_Initialize) then - Ent := E; - end if; - - -- If the call is in an instance, and the called entity is not - -- defined in the same instance, then the elaboration issue focuses - -- around the unit containing the template, it is this unit which - -- requires an Elaborate_All. + -- Check cases of internal units - -- However, if we are doing dynamic elaboration, we need to chase the - -- call in the usual manner. + Callee_Unit_Internal := + Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (E_Scope))); - -- We also need to chase the call in the usual manner if it is a call - -- to a generic formal parameter, since that case was not handled as - -- part of the processing of the template. + -- Do not give a warning if the with'ed unit is internal and this is + -- the generic instantiation case (this saves a lot of hassle dealing + -- with the Text_IO special child units) - Inst_Caller := Instantiation (Get_Source_File_Index (Sloc (N))); - Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent))); + if Callee_Unit_Internal and Inst_Case then + return; + end if; - if Inst_Caller = No_Location then - Unit_Caller := No_Unit; - else - Unit_Caller := Get_Source_Unit (N); - end if; + if C_Scope = Standard_Standard then + Caller_Unit_Internal := False; + else + Caller_Unit_Internal := + Is_Internal_File_Name (Unit_File_Name (Get_Source_Unit (C_Scope))); + end if; - if Inst_Callee = No_Location then - Unit_Callee := No_Unit; - else - Unit_Callee := Get_Source_Unit (Ent); - end if; + -- Do not give a warning if the with'ed unit is internal and the + -- caller is not internal (since the binder always elaborates + -- internal units first). - if Unit_Caller /= No_Unit - and then Unit_Callee /= Unit_Caller - and then not Dynamic_Elaboration_Checks - and then not Is_Call_Of_Generic_Formal (N) - then - E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller)); + if Callee_Unit_Internal and (not Caller_Unit_Internal) then + return; + end if; - -- If we don't get a spec entity, just ignore call. Not quite - -- clear why this check is necessary. ??? + -- For now, if debug flag -gnatdE is not set, do no checking for + -- one internal unit withing another. This fixes the problem with + -- the sgi build and storage errors. To be resolved later ??? - if No (E_Scope) then - return; - end if; + if (Callee_Unit_Internal and Caller_Unit_Internal) + and not Debug_Flag_EE + then + return; + end if; - -- Otherwise step to enclosing compilation unit + if Is_TSS (E, TSS_Deep_Initialize) then + Ent := E; + end if; - while not Is_Compilation_Unit (E_Scope) loop - E_Scope := Scope (E_Scope); - end loop; + -- If the call is in an instance, and the called entity is not + -- defined in the same instance, then the elaboration issue focuses + -- around the unit containing the template, it is this unit which + -- requires an Elaborate_All. - -- For the case where N is not an instance, and is not a call within - -- instance to other than a generic formal, we recompute E_Scope - -- for the error message, since we do NOT want to go to the unit - -- which has the ultimate declaration in the case of renaming and - -- derivation and we also want to go to the generic unit in the - -- case of an instance, and no further. + -- However, if we are doing dynamic elaboration, we need to chase the + -- call in the usual manner. - else - -- Loop to carefully follow renamings and derivations one step - -- outside the current unit, but not further. + -- We also need to chase the call in the usual manner if it is a call + -- to a generic formal parameter, since that case was not handled as + -- part of the processing of the template. - if not (Inst_Case or Variable_Case) - and then Present (Alias (Ent)) - then - E_Scope := Alias (Ent); - else - E_Scope := Ent; - end if; + Inst_Caller := Instantiation (Get_Source_File_Index (Sloc (N))); + Inst_Callee := Instantiation (Get_Source_File_Index (Sloc (Ent))); - loop - while not Is_Compilation_Unit (E_Scope) loop - E_Scope := Scope (E_Scope); - end loop; + if Inst_Caller = No_Location then + Unit_Caller := No_Unit; + else + Unit_Caller := Get_Source_Unit (N); + end if; - -- If E_Scope is the same as C_Scope, it means that there - -- definitely was a local renaming or derivation, and we - -- are not yet out of the current unit. + if Inst_Callee = No_Location then + Unit_Callee := No_Unit; + else + Unit_Callee := Get_Source_Unit (Ent); + end if; - exit when E_Scope /= C_Scope; - Ent := Alias (Ent); - E_Scope := Ent; + if Unit_Caller /= No_Unit + and then Unit_Callee /= Unit_Caller + and then not Dynamic_Elaboration_Checks + and then not Is_Call_Of_Generic_Formal (N) + then + E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller)); - -- If no alias, there is a previous error + -- If we don't get a spec entity, just ignore call. Not quite + -- clear why this check is necessary. ??? - if No (Ent) then - Check_Error_Detected; - return; - end if; - end loop; - end if; - - if Within_Elaborate_All (Current_Sem_Unit, E_Scope) then + if No (E_Scope) then return; end if; - -- Find top level scope for called entity (not following renamings - -- or derivations). This is where the Elaborate_All will go if it - -- is needed. We start with the called entity, except in the case - -- of an initialization procedure outside the current package, where - -- the init proc is in the root package, and we start from the entity - -- of the name in the call. - - declare - Ent : constant Entity_Id := Get_Referenced_Ent (N); - begin - if Is_Init_Proc (Ent) - and then not In_Same_Extended_Unit (N, Ent) - then - W_Scope := Scope (Ent); - else - W_Scope := E; - end if; - end; - - -- Now loop through scopes to get to the enclosing compilation unit + -- Otherwise step to enclosing compilation unit - while not Is_Compilation_Unit (W_Scope) loop - W_Scope := Scope (W_Scope); + while not Is_Compilation_Unit (E_Scope) loop + E_Scope := Scope (E_Scope); end loop; - -- Now check if an elaborate_all (or dynamic check) is needed + -- For the case where N is not an instance, and is not a call within + -- instance to other than a generic formal, we recompute E_Scope + -- for the error message, since we do NOT want to go to the unit + -- which has the ultimate declaration in the case of renaming and + -- derivation and we also want to go to the generic unit in the + -- case of an instance, and no further. - if not Suppress_Elaboration_Warnings (Ent) - and then not Elaboration_Checks_Suppressed (Ent) - and then not Suppress_Elaboration_Warnings (E_Scope) - and then not Elaboration_Checks_Suppressed (E_Scope) - and then ((Elab_Warnings or Elab_Info_Messages) - or else SPARK_Mode = On) - and then Generate_Warnings + else + -- Loop to carefully follow renamings and derivations one step + -- outside the current unit, but not further. + + if not (Inst_Case or Variable_Case) + and then Present (Alias (Ent)) then - -- Instantiation case + E_Scope := Alias (Ent); + else + E_Scope := Ent; + end if; - if Inst_Case then - if SPARK_Mode = On then - Error_Msg_NE - ("instantiation of & during elaboration in SPARK", - N, Ent); + loop + while not Is_Compilation_Unit (E_Scope) loop + E_Scope := Scope (E_Scope); + end loop; - else - Elab_Warning - ("instantiation of & may raise Program_Error?l?", - "info: instantiation of & during elaboration?$?", Ent); - end if; + -- If E_Scope is the same as C_Scope, it means that there + -- definitely was a local renaming or derivation, and we + -- are not yet out of the current unit. - -- Indirect call case, info message only in static elaboration - -- case, because the attribute reference itself cannot raise an - -- exception. Note that SPARK does not permit indirect calls. + exit when E_Scope /= C_Scope; + Ent := Alias (Ent); + E_Scope := Ent; - elsif Access_Case then - Elab_Warning - ("", "info: access to & during elaboration?$?", Ent); + -- If no alias, there is a previous error - -- Variable reference in SPARK mode + if No (Ent) then + Check_Error_Detected; + return; + end if; + end loop; + end if; - elsif Variable_Case then - Error_Msg_NE - ("reference to & during elaboration in SPARK", N, Ent); + if Within_Elaborate_All (Current_Sem_Unit, E_Scope) then + return; + end if; - -- Subprogram call case + -- Now check if an Elaborate_All (or dynamic check) is needed - else - if Nkind (Name (N)) in N_Has_Entity - and then Is_Init_Proc (Entity (Name (N))) - and then Comes_From_Source (Ent) - then - Elab_Warning - ("implicit call to & may raise Program_Error?l?", - "info: implicit call to & during elaboration?$?", - Ent); + if not Suppress_Elaboration_Warnings (Ent) + and then not Elaboration_Checks_Suppressed (Ent) + and then not Suppress_Elaboration_Warnings (E_Scope) + and then not Elaboration_Checks_Suppressed (E_Scope) + and then ((Elab_Warnings or Elab_Info_Messages) + or else SPARK_Mode = On) + and then Generate_Warnings + then + -- Instantiation case - elsif SPARK_Mode = On then - Error_Msg_NE - ("call to & during elaboration in SPARK", N, Ent); + if Inst_Case then + if SPARK_Mode = On then + Error_Msg_NE + ("instantiation of & during elaboration in SPARK", N, Ent); - else - Elab_Warning - ("call to & may raise Program_Error?l?", - "info: call to & during elaboration?$?", - Ent); - end if; + else + Elab_Warning + ("instantiation of & may raise Program_Error?l?", + "info: instantiation of & during elaboration?$?", Ent); end if; - Error_Msg_Qual_Level := Nat'Last; + -- Indirect call case, info message only in static elaboration + -- case, because the attribute reference itself cannot raise an + -- exception. Note that SPARK does not permit indirect calls. - -- Case of Elaborate_All not present and required, for SPARK this - -- is an error, so give an error message. + elsif Access_Case then + Elab_Warning ("", "info: access to & during elaboration?$?", Ent); - if SPARK_Mode = On then - Error_Msg_NE - ("\Elaborate_All pragma required for&", N, W_Scope); + -- Variable reference in SPARK mode + + elsif Variable_Case then + Error_Msg_NE + ("reference to & during elaboration in SPARK", N, Ent); - -- Otherwise we generate an implicit pragma. For a subprogram - -- instantiation, Elaborate is good enough, since no transitive - -- call is possible at elaboration time in this case. + -- Subprogram call case - elsif Nkind (N) in N_Subprogram_Instantiation then + else + if Nkind (Name (N)) in N_Has_Entity + and then Is_Init_Proc (Entity (Name (N))) + and then Comes_From_Source (Ent) + then Elab_Warning - ("\missing pragma Elaborate for&?l?", - "\implicit pragma Elaborate for& generated?$?", - W_Scope); + ("implicit call to & may raise Program_Error?l?", + "info: implicit call to & during elaboration?$?", + Ent); - -- For all other cases, we need an implicit Elaborate_All + elsif SPARK_Mode = On then + Error_Msg_NE ("call to & during elaboration in SPARK", N, Ent); else Elab_Warning - ("\missing pragma Elaborate_All for&?l?", - "\implicit pragma Elaborate_All for & generated?$?", - W_Scope); + ("call to & may raise Program_Error?l?", + "info: call to & during elaboration?$?", + Ent); end if; + end if; - Error_Msg_Qual_Level := 0; + Error_Msg_Qual_Level := Nat'Last; - -- Take into account the flags related to elaboration warning - -- messages when enumerating the various calls involved. This - -- ensures the proper pairing of the main warning and the - -- clarification messages generated by Output_Calls. + -- Case of Elaborate_All not present and required, for SPARK this + -- is an error, so give an error message. - Output_Calls (N, Check_Elab_Flag => True); + if SPARK_Mode = On then + Error_Msg_NE ("\Elaborate_All pragma required for&", N, W_Scope); - -- Set flag to prevent further warnings for same unit unless in - -- All_Errors_Mode. + -- Otherwise we generate an implicit pragma. For a subprogram + -- instantiation, Elaborate is good enough, since no transitive + -- call is possible at elaboration time in this case. - if not All_Errors_Mode and not Dynamic_Elaboration_Checks then - Set_Suppress_Elaboration_Warnings (W_Scope, True); - end if; + elsif Nkind (N) in N_Subprogram_Instantiation then + Elab_Warning + ("\missing pragma Elaborate for&?l?", + "\implicit pragma Elaborate for& generated?$?", + W_Scope); + + -- For all other cases, we need an implicit Elaborate_All + + else + Elab_Warning + ("\missing pragma Elaborate_All for&?l?", + "\implicit pragma Elaborate_All for & generated?$?", + W_Scope); end if; - -- Check for runtime elaboration check required + Error_Msg_Qual_Level := 0; - if Dynamic_Elaboration_Checks then - if not Elaboration_Checks_Suppressed (Ent) - and then not Elaboration_Checks_Suppressed (W_Scope) - and then not Elaboration_Checks_Suppressed (E_Scope) - and then not Cunit_SC - then - -- Runtime elaboration check required. Generate check of the - -- elaboration Boolean for the unit containing the entity. + -- Take into account the flags related to elaboration warning + -- messages when enumerating the various calls involved. This + -- ensures the proper pairing of the main warning and the + -- clarification messages generated by Output_Calls. - -- Note that for this case, we do check the real unit (the one - -- from following renamings, since that is the issue). + Output_Calls (N, Check_Elab_Flag => True); - -- Could this possibly miss a useless but required PE??? + -- Set flag to prevent further warnings for same unit unless in + -- All_Errors_Mode. - Insert_Elab_Check (N, - Make_Attribute_Reference (Loc, - Attribute_Name => Name_Elaborated, - Prefix => - New_Occurrence_Of (Spec_Entity (E_Scope), Loc))); + if not All_Errors_Mode and not Dynamic_Elaboration_Checks then + Set_Suppress_Elaboration_Warnings (W_Scope, True); + end if; + end if; - -- Prevent duplicate elaboration checks on the same call, - -- which can happen if the body enclosing the call appears - -- itself in a call whose elaboration check is delayed. + -- Check for runtime elaboration check required - if Nkind (N) in N_Subprogram_Call then - Set_No_Elaboration_Check (N); - end if; - end if; + if Dynamic_Elaboration_Checks then + if not Elaboration_Checks_Suppressed (Ent) + and then not Elaboration_Checks_Suppressed (W_Scope) + and then not Elaboration_Checks_Suppressed (E_Scope) + and then not Cunit_SC + then + -- Runtime elaboration check required. Generate check of the + -- elaboration Boolean for the unit containing the entity. - -- Case of static elaboration model + -- Note that for this case, we do check the real unit (the one + -- from following renamings, since that is the issue). - else - -- Do not do anything if elaboration checks suppressed. Note that - -- we check Ent here, not E, since we want the real entity for the - -- body to see if checks are suppressed for it, not the dummy - -- entry for renamings or derivations. - - if Elaboration_Checks_Suppressed (Ent) - or else Elaboration_Checks_Suppressed (E_Scope) - or else Elaboration_Checks_Suppressed (W_Scope) - then - null; + -- Could this possibly miss a useless but required PE??? - -- Do not generate an Elaborate_All for finalization routines - -- which perform partial clean up as part of initialization. + Insert_Elab_Check (N, + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Elaborated, + Prefix => + New_Occurrence_Of (Spec_Entity (E_Scope), Loc))); - elsif In_Init_Proc and then Is_Finalization_Procedure (Ent) then - null; + -- Prevent duplicate elaboration checks on the same call, + -- which can happen if the body enclosing the call appears + -- itself in a call whose elaboration check is delayed. - -- Here we need to generate an implicit elaborate all + if Nkind (N) in N_Subprogram_Call then + Set_No_Elaboration_Check (N); + end if; + end if; - else - -- Generate Elaborate_all warning unless suppressed + -- Case of static elaboration model - if (Elab_Info_Messages and Generate_Warnings and not Inst_Case) - and then not Suppress_Elaboration_Warnings (Ent) - and then not Suppress_Elaboration_Warnings (E_Scope) - and then not Suppress_Elaboration_Warnings (W_Scope) - then - Error_Msg_Node_2 := W_Scope; - Error_Msg_NE - ("info: call to& in elaboration code " & - "requires pragma Elaborate_All on&?$?", N, E); - end if; + else + -- Do not do anything if elaboration checks suppressed. Note that + -- we check Ent here, not E, since we want the real entity for the + -- body to see if checks are suppressed for it, not the dummy + -- entry for renamings or derivations. + + if Elaboration_Checks_Suppressed (Ent) + or else Elaboration_Checks_Suppressed (E_Scope) + or else Elaboration_Checks_Suppressed (W_Scope) + then + null; + + -- Do not generate an Elaborate_All for finalization routines + -- which perform partial clean up as part of initialization. - -- Set indication for binder to generate Elaborate_All + elsif In_Init_Proc and then Is_Finalization_Procedure (Ent) then + null; + + -- Here we need to generate an implicit elaborate all - Set_Elaboration_Constraint (N, E, W_Scope); + else + -- Generate Elaborate_All warning unless suppressed + + if (Elab_Info_Messages and Generate_Warnings and not Inst_Case) + and then not Suppress_Elaboration_Warnings (Ent) + and then not Suppress_Elaboration_Warnings (E_Scope) + and then not Suppress_Elaboration_Warnings (W_Scope) + then + Error_Msg_Node_2 := W_Scope; + Error_Msg_NE + ("info: call to& in elaboration code " & + "requires pragma Elaborate_All on&?$?", N, E); end if; - end if; - -- Case of entity is in same unit as call or instantiation + -- Set indication for binder to generate Elaborate_All - elsif not Inter_Unit_Only then - Check_Internal_Call (N, Ent, Outer_Scope, E); + Set_Elaboration_Constraint (N, E, W_Scope); + end if; end if; end Check_A_Call; diff --git a/gcc/ada/sem_prag.adb b/gcc/ada/sem_prag.adb index fbe5f6c4f97..d516c23200a 100644 --- a/gcc/ada/sem_prag.adb +++ b/gcc/ada/sem_prag.adb @@ -5875,7 +5875,6 @@ package body Sem_Prag is E : Entity_Id; E_Id : Node_Id; K : Node_Kind; - Utyp : Entity_Id; procedure Set_Atomic_VFA (E : Entity_Id); -- Set given type as Is_Atomic or Is_Volatile_Full_Access. Also, if @@ -6053,46 +6052,6 @@ package body Sem_Prag is then Set_Has_Delayed_Freeze (E); end if; - - -- An interesting improvement here. If an object of composite - -- type X is declared atomic, and the type X isn't, that's a - -- pity, since it may not have appropriate alignment etc. We - -- can rescue this in the special case where the object and - -- type are in the same unit by just setting the type as - -- atomic, so that the back end will process it as atomic. - - -- Note: we used to do this for elementary types as well, - -- but that turns out to be a bad idea and can have unwanted - -- effects, most notably if the type is elementary, the object - -- a simple component within a record, and both are in a spec: - -- every object of this type in the entire program will be - -- treated as atomic, thus incurring a potentially costly - -- synchronization operation for every access. - - -- For Volatile_Full_Access we can do this for elementary types - -- too, since there is no issue of atomic synchronization. - - -- Of course it would be best if the back end could just adjust - -- the alignment etc for the specific object, but that's not - -- something we are capable of doing at this point. - - Utyp := Underlying_Type (Etype (E)); - - if Present (Utyp) - and then (Is_Composite_Type (Utyp) - or else Prag_Id = Pragma_Volatile_Full_Access) - and then Sloc (E) > No_Location - and then Sloc (Utyp) > No_Location - and then - Get_Source_File_Index (Sloc (E)) = - Get_Source_File_Index (Sloc (Utyp)) - then - if Prag_Id = Pragma_Volatile_Full_Access then - Set_Is_Volatile_Full_Access (Utyp); - else - Set_Is_Atomic (Utyp); - end if; - end if; end if; -- Atomic/Shared/Volatile_Full_Access imply Independent