X-Git-Url: http://git.sourceforge.jp/view?a=blobdiff_plain;f=gcc%2Fada%2Fsem_elab.adb;h=6df8c3249b424309edb51daead3c96f25fad3ca1;hb=80de24b889871941334b6aeae5cdc103907fe92c;hp=e3f72e4f112a1b90579e72a03a1d25f32710bc73;hpb=343d35dc66bb93bde59e03709f7cb27e3d9c7d8f;p=pf3gnuchains%2Fgcc-fork.git diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index e3f72e4f112..6df8c3249b4 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -6,18 +6,17 @@ -- -- -- B o d y -- -- -- --- Copyright (C) 1997-2006, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2011, Free Software Foundation, Inc. -- -- -- -- GNAT is free software; you can redistribute it and/or modify it under -- -- terms of the GNU General Public License as published by the Free Soft- -- --- ware Foundation; either version 2, or (at your option) any later ver- -- +-- ware Foundation; either version 3, or (at your option) any later ver- -- -- sion. GNAT is distributed in the hope that it will be useful, but WITH- -- -- OUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY -- -- or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License -- -- for more details. You should have received a copy of the GNU General -- --- Public License distributed with GNAT; see file COPYING. If not, write -- --- to the Free Software Foundation, 51 Franklin Street, Fifth Floor, -- --- Boston, MA 02110-1301, USA. -- +-- Public License distributed with GNAT; see file COPYING3. If not, go to -- +-- http://www.gnu.org/licenses for a complete copy of the license. -- -- -- -- GNAT was originally developed by the GNAT team at New York University. -- -- Extensive contributions were provided by Ada Core Technologies Inc. -- @@ -44,10 +43,12 @@ with Output; use Output; with Restrict; use Restrict; with Rident; use Rident; with Sem; use Sem; +with Sem_Aux; use Sem_Aux; with Sem_Cat; use Sem_Cat; with Sem_Ch7; use Sem_Ch7; with Sem_Ch8; use Sem_Ch8; with Sem_Res; use Sem_Res; +with Sem_Type; use Sem_Type; with Sem_Util; use Sem_Util; with Sinfo; use Sinfo; with Sinput; use Sinput; @@ -55,15 +56,16 @@ with Snames; use Snames; with Stand; use Stand; with Table; with Tbuild; use Tbuild; +with Uintp; use Uintp; with Uname; use Uname; package body Sem_Elab is - -- The following table records the recursive call chain for output - -- in the Output routine. Each entry records the call node and the - -- entity of the called routine. The number of entries in the table - -- (i.e. the value of Elab_Call.Last) indicates the current depth - -- of recursion and is used to identify the outer level. + -- The following table records the recursive call chain for output in the + -- Output routine. Each entry records the call node and the entity of the + -- called routine. The number of entries in the table (i.e. the value of + -- Elab_Call.Last) indicates the current depth of recursion and is used to + -- identify the outer level. type Elab_Call_Entry is record Cloc : Source_Ptr; @@ -78,10 +80,10 @@ package body Sem_Elab is Table_Increment => 100, Table_Name => "Elab_Call"); - -- This table is initialized at the start of each outer level call. - -- It holds the entities for all subprograms that have been examined - -- for this particular outer level call, and is used to prevent both - -- infinite recursion, and useless reanalysis of bodies already seen + -- This table is initialized at the start of each outer level call. It + -- holds the entities for all subprograms that have been examined for this + -- particular outer level call, and is used to prevent both infinite + -- recursion, and useless reanalysis of bodies already seen package Elab_Visited is new Table.Table ( Table_Component_Type => Entity_Id, @@ -128,9 +130,8 @@ package body Sem_Elab is Table_Name => "Delay_Check"); C_Scope : Entity_Id; - -- Top level scope of current scope. We need to compute this only - -- once at the outer level, i.e. for a call to Check_Elab_Call from - -- outside this unit. + -- Top level scope of current scope. Compute this only once at the outer + -- level, i.e. for a call to Check_Elab_Call from outside this unit. Outer_Level_Sloc : Source_Ptr; -- Save Sloc value for outer level call node for comparisons of source @@ -150,9 +151,9 @@ package body Sem_Elab is Delaying_Elab_Checks : Boolean := True; -- This is set True till the compilation is complete, including the - -- insertion of all instance bodies. Then when Check_Elab_Calls is - -- called, the delay table is used to make the delayed calls and - -- this flag is reset to False, so that the calls are processed + -- insertion of all instance bodies. Then when Check_Elab_Calls is called, + -- the delay table is used to make the delayed calls and this flag is reset + -- to False, so that the calls are processed ----------------------- -- Local Subprograms -- @@ -177,17 +178,18 @@ package body Sem_Elab is E : Entity_Id; Outer_Scope : Entity_Id; Inter_Unit_Only : Boolean; - Generate_Warnings : Boolean := True); - -- This is the internal recursive routine that is called to check for - -- a possible elaboration error. The argument N is a subprogram call - -- or generic instantiation to be checked, and E is the entity of - -- the called subprogram, or instantiated generic unit. The flag - -- Outer_Scope is the outer level scope for the original call. - -- Inter_Unit_Only is set if the call is only to be checked in the - -- case where it is to another unit (and skipped if within a unit). - -- Generate_Warnings is set to False to suppress warning messages - -- about missing pragma Elaborate_All's. These messages are not - -- wanted for inner calls in the dynamic model. + Generate_Warnings : Boolean := True; + In_Init_Proc : Boolean := False); + -- This is the internal recursive routine that is called to check for a + -- possible elaboration error. The argument N is a subprogram call or + -- generic instantiation to be checked, and E is the entity of the called + -- subprogram, or instantiated generic unit. The flag Outer_Scope is the + -- outer level scope for the original call. Inter_Unit_Only is set if the + -- call is only to be checked in the case where it is to another unit (and + -- skipped if within a unit). Generate_Warnings is set to False to suppress + -- warning messages about missing pragma Elaborate_All's. These messages + -- are not wanted for inner calls in the dynamic model. Flag In_Init_Proc + -- should be set whenever the current context is a type init proc. procedure Check_Bad_Instantiation (N : Node_Id); -- N is a node for an instantiation (if called with any other node kind, @@ -208,14 +210,14 @@ package body Sem_Elab is E : Entity_Id; Outer_Scope : Entity_Id; Orig_Ent : Entity_Id); - -- N is a function call or procedure statement call node and E is - -- the entity of the called function, which is within the current - -- compilation unit (where subunits count as part of the parent). - -- This call checks if this call, or any call within any accessed - -- body could cause an ABE, and if so, outputs a warning. Orig_Ent - -- differs from E only in the case of renamings, and points to the - -- original name of the entity. This is used for error messages. - -- Outer_Scope is the outer level scope for the original call. + -- N is a function call or procedure statement call node and E is the + -- entity of the called function, which is within the current compilation + -- unit (where subunits count as part of the parent). This call checks if + -- this call, or any call within any accessed body could cause an ABE, and + -- if so, outputs a warning. Orig_Ent differs from E only in the case of + -- renamings, and points to the original name of the entity. This is used + -- for error messages. Outer_Scope is the outer level scope for the + -- original call. procedure Check_Internal_Call_Continue (N : Node_Id; @@ -225,33 +227,10 @@ package body Sem_Elab is -- The processing for Check_Internal_Call is divided up into two phases, -- and this represents the second phase. The second phase is delayed if -- Delaying_Elab_Calls is set to True. In this delayed case, the first - -- phase makes an entry in the Delay_Check table, which is processed - -- when Check_Elab_Calls is called. N, E and Orig_Ent are as for the call - -- to Check_Internal_Call. Outer_Scope is the outer level scope for - -- the original call. - - procedure Set_Elaboration_Constraint - (Call : Node_Id; - Subp : Entity_Id; - Scop : Entity_Id); - -- The current unit U may depend semantically on some unit P which is not - -- in the current context. If there is an elaboration call that reaches P, - -- we need to indicate that P requires an Elaborate_All, but this is not - -- effective in U's ali file, if there is no with_clause for P. In this - -- case we add the Elaborate_All on the unit Q that directly or indirectly - -- makes P available. This can happen in two cases: - -- - -- a) Q declares a subtype of a type declared in P, and the call is an - -- initialization call for an object of that subtype. - -- - -- b) Q declares an object of some tagged type whose root type is - -- declared in P, and the initialization call uses object notation on - -- that object to reach a primitive operation or a classwide operation - -- declared in P. - -- - -- If P appears in the context of U, the current processing is correct. - -- Otherwise we must identify these two cases to retrieve Q and place the - -- Elaborate_All_Desirable on it. + -- phase makes an entry in the Delay_Check table, which is processed when + -- Check_Elab_Calls is called. N, E and Orig_Ent are as for the call to + -- Check_Internal_Call. Outer_Scope is the outer level scope for the + -- original call. function Has_Generic_Body (N : Node_Id) return Boolean; -- N is a generic package instantiation node, and this routine determines @@ -269,16 +248,19 @@ package body Sem_Elab is -- inevitable, given the optional body semantics of Ada). procedure Insert_Elab_Check (N : Node_Id; C : Node_Id := Empty); - -- Given code for an elaboration check (or unconditional raise if - -- the check is not needed), inserts the code in the appropriate - -- place. N is the call or instantiation node for which the check - -- code is required. C is the test whose failure triggers the raise. + -- Given code for an elaboration check (or unconditional raise if the check + -- is not needed), inserts the code in the appropriate place. N is the call + -- or instantiation node for which the check code is required. C is the + -- test whose failure triggers the raise. + + function Is_Finalization_Procedure (Id : Entity_Id) return Boolean; + -- Determine whether entity Id denotes a [Deep_]Finalize procedure procedure Output_Calls (N : Node_Id); - -- Outputs chain of calls stored in the Elab_Call table. The caller - -- has already generated the main warning message, so the warnings - -- generated are all continuation messages. The argument is the - -- call node at which the messages are to be placed. + -- Outputs chain of calls stored in the Elab_Call table. The caller has + -- already generated the main warning message, so the warnings generated + -- are all continuation messages. The argument is the call node at which + -- the messages are to be placed. function Same_Elaboration_Scope (Scop1, Scop2 : Entity_Id) return Boolean; -- Given two scopes, determine whether they are the same scope from an @@ -288,18 +270,40 @@ package body Sem_Elab is -- On entry C_Scope is set to some scope. On return, C_Scope is reset -- to be the enclosing compilation unit of this scope. + procedure Set_Elaboration_Constraint + (Call : Node_Id; + Subp : Entity_Id; + Scop : Entity_Id); + -- The current unit U may depend semantically on some unit P which is not + -- in the current context. If there is an elaboration call that reaches P, + -- we need to indicate that P requires an Elaborate_All, but this is not + -- effective in U's ali file, if there is no with_clause for P. In this + -- case we add the Elaborate_All on the unit Q that directly or indirectly + -- makes P available. This can happen in two cases: + -- + -- a) Q declares a subtype of a type declared in P, and the call is an + -- initialization call for an object of that subtype. + -- + -- b) Q declares an object of some tagged type whose root type is + -- declared in P, and the initialization call uses object notation on + -- that object to reach a primitive operation or a classwide operation + -- declared in P. + -- + -- If P appears in the context of U, the current processing is correct. + -- Otherwise we must identify these two cases to retrieve Q and place the + -- Elaborate_All_Desirable on it. + function Spec_Entity (E : Entity_Id) return Entity_Id; - -- Given a compilation unit entity, if it is a spec entity, it is - -- returned unchanged. If it is a body entity, then the spec for - -- the corresponding spec is returned + -- Given a compilation unit entity, if it is a spec entity, it is returned + -- unchanged. If it is a body entity, then the spec for the corresponding + -- spec is returned procedure Supply_Bodies (N : Node_Id); -- Given a node, N, that is either a subprogram declaration or a package -- declaration, this procedure supplies dummy bodies for the subprogram -- or for all subprograms in the package. If the given node is not one -- of these two possibilities, then Supply_Bodies does nothing. The - -- dummy body is supplied by setting the subprogram to be Imported with - -- convention Stubbed. + -- dummy body contains a single Raise statement. procedure Supply_Bodies (L : List_Id); -- Calls Supply_Bodies for all elements of the given list L @@ -474,18 +478,18 @@ package body Sem_Elab is E : Entity_Id; Outer_Scope : Entity_Id; Inter_Unit_Only : Boolean; - Generate_Warnings : Boolean := True) + Generate_Warnings : Boolean := True; + In_Init_Proc : Boolean := False) is Loc : constant Source_Ptr := Sloc (N); Ent : Entity_Id; Decl : Node_Id; E_Scope : Entity_Id; - -- Top level scope of entity for called subprogram. This - -- value includes following renamings and derivations, so - -- this scope can be in a non-visible unit. This is the - -- scope that is to be investigated to see whether an - -- elaboration check is required. + -- Top level scope of entity for called subprogram. This value includes + -- following renamings and derivations, so this scope can be in a + -- non-visible unit. This is the scope that is to be investigated to + -- see whether an elaboration check is required. W_Scope : Entity_Id; -- Top level scope of directly called entity for subprogram. This @@ -496,7 +500,7 @@ package body Sem_Elab is -- calls and calls involving object notation) where W_Scope might not -- be in the context of the current unit, and there is an intermediate -- package that is, in which case the Elaborate_All has to be placed - -- on this intedermediate package. These special cases are handled in + -- on this intermediate package. These special cases are handled in -- Set_Elaboration_Constraint. Body_Acts_As_Spec : Boolean; @@ -532,8 +536,8 @@ package body Sem_Elab is return; end if; - -- Go to parent for derived subprogram, or to original subprogram - -- in the case of a renaming (Alias covers both these cases) + -- Go to parent for derived subprogram, or to original subprogram in the + -- case of a renaming (Alias covers both these cases). Ent := E; loop @@ -603,9 +607,7 @@ package body Sem_Elab is -- No checks needed for pure or preelaborated compilation units - if Is_Pure (E_Scope) - or else Is_Preelaborated (E_Scope) - then + if Is_Pure (E_Scope) or else Is_Preelaborated (E_Scope) then return; end if; @@ -647,16 +649,16 @@ package body Sem_Elab is return; end if; - -- 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. + -- 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 Is_Generic_Instance (Ent) and not Dynamic_Elaboration_Checks then return; 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 + -- 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. @@ -664,11 +666,10 @@ package body Sem_Elab is if Body_Acts_As_Spec then if Is_TSS (Ent, TSS_Deep_Initialize) then declare - Typ : Entity_Id; + Typ : constant Entity_Id := Etype (First_Formal (Ent)); Init : Entity_Id; - begin - Typ := Etype (Next_Formal (First_Formal (Ent))); + begin if not Is_Controlled (Typ) then return; else @@ -763,8 +764,8 @@ package body Sem_Elab is then E_Scope := Spec_Entity (Cunit_Entity (Unit_Caller)); - -- If we don't get a spec entity, just ignore call. Not - -- quite clear why this check is necessary. + -- If we don't get a spec entity, just ignore call. Not quite + -- clear why this check is necessary. ??? if No (E_Scope) then return; @@ -776,16 +777,15 @@ package body Sem_Elab is E_Scope := Scope (E_Scope); end loop; - -- For the case N is not an instance, or a call within instance - -- 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. + -- For the case N is not an instance, or a call within instance, 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. else - -- Loop to carefully follow renamings and derivations - -- one step outside the current unit, but not further. + -- Loop to carefully follow renamings and derivations one step + -- outside the current unit, but not further. if not Inst_Case and then Present (Alias (Ent)) @@ -849,38 +849,77 @@ package body Sem_Elab is and then Elab_Warnings and then Generate_Warnings then - if Inst_Case then - Error_Msg_NE - ("instantiation of& may raise Program_Error?", N, Ent); + Generate_Elab_Warnings : declare + procedure Elab_Warning + (Msg_D : String; + Msg_S : String; + Ent : Node_Or_Entity_Id); + -- Generate a call to Error_Msg_NE with parameters Msg_D or + -- Msg_S (for dynamic or static elaboration model), N and Ent. + + ------------------ + -- Elab_Warning -- + ------------------ + + procedure Elab_Warning + (Msg_D : String; + Msg_S : String; + Ent : Node_Or_Entity_Id) + is + begin + if Dynamic_Elaboration_Checks then + Error_Msg_NE (Msg_D, N, Ent); + else + Error_Msg_NE (Msg_S, N, Ent); + end if; + end Elab_Warning; - else - if Is_Init_Proc (Entity (Name (N))) - and then Comes_From_Source (Ent) - then - Error_Msg_NE - ("implicit call to & may raise Program_Error?", N, Ent); + -- Start of processing for Generate_Elab_Warnings + + begin + if Inst_Case then + Elab_Warning + ("instantiation of& may raise Program_Error?", + "info: instantiation of& during elaboration?", Ent); else - Error_Msg_NE - ("call to & may raise Program_Error?", N, Ent); + 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?", + "info: implicit call to & during elaboration?", + Ent); + + else + Elab_Warning + ("call to & may raise Program_Error?", + "info: call to & during elaboration?", + Ent); + end if; end if; - end if; - Error_Msg_Qual_Level := Nat'Last; + Error_Msg_Qual_Level := Nat'Last; - if Nkind (N) in N_Subprogram_Instantiation then - Error_Msg_NE - ("\missing pragma Elaborate for&?", N, W_Scope); - else - Error_Msg_NE - ("\missing pragma Elaborate_All for&?", N, W_Scope); - end if; + if Nkind (N) in N_Subprogram_Instantiation then + Elab_Warning + ("\missing pragma Elaborate for&?", + "\info: implicit pragma Elaborate for& generated?", + W_Scope); + else + Elab_Warning + ("\missing pragma Elaborate_All for&?", + "\info: implicit pragma Elaborate_All for & generated?", + W_Scope); + end if; + end Generate_Elab_Warnings; Error_Msg_Qual_Level := 0; Output_Calls (N); - -- Set flag to prevent further warnings for same unit - -- unless in All_Errors_Mode. + -- Set flag to prevent further warnings for same unit unless in + -- All_Errors_Mode. if not All_Errors_Mode and not Dynamic_Elaboration_Checks then Set_Suppress_Elaboration_Warnings (W_Scope, True); @@ -898,26 +937,34 @@ package body Sem_Elab is -- Runtime elaboration check required. Generate check of the -- elaboration Boolean for the unit containing the entity. - -- Note that for this case, we do check the real unit (the - -- one from following renamings, since that is the issue!) + -- Note that for this case, we do check the real unit (the one + -- from following renamings, since that is the issue!) -- Could this possibly miss a useless but required PE??? Insert_Elab_Check (N, Make_Attribute_Reference (Loc, Attribute_Name => Name_Elaborated, - Prefix => - New_Occurrence_Of - (Spec_Entity (E_Scope), Loc))); + Prefix => New_Occurrence_Of (Spec_Entity (E_Scope), Loc))); + + -- 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. + + if Nkind_In (N, N_Function_Call, + N_Procedure_Call_Statement) + then + Set_No_Elaboration_Check (N); + end if; end if; -- Case of static elaboration model 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. + -- 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) @@ -925,6 +972,14 @@ package body Sem_Elab is then null; + -- Do not generate an Elaborate_All for finalization routines + -- which perform partial clean up as part of initialization. + + elsif In_Init_Proc + and then Is_Finalization_Procedure (Ent) + then + null; + -- Here we need to generate an implicit elaborate all else @@ -1064,8 +1119,9 @@ package body Sem_Elab is --------------------- procedure Check_Elab_Call - (N : Node_Id; - Outer_Scope : Entity_Id := Empty) + (N : Node_Id; + Outer_Scope : Entity_Id := Empty; + In_Init_Proc : Boolean := False) is Ent : Entity_Id; P : Node_Id; @@ -1073,7 +1129,7 @@ package body Sem_Elab is function Get_Called_Ent return Entity_Id; -- Retrieve called entity. If this is a call to a protected subprogram, -- entity is a selected component. The callable entity may be absent, - -- in which case there is no check to perform. This happens with + -- in which case there is no check to perform. This happens with -- non-analyzed calls in nested generics. -------------------- @@ -1163,8 +1219,8 @@ package body Sem_Elab is -- is at the time of the actual call (statically speaking) that we must -- do our static check, not at the time of its initial analysis). - -- However, we have to check calls within component definitions (e.g., a - -- function call that determines an array component bound), so we + -- However, we have to check calls within component definitions (e.g. + -- a function call that determines an array component bound), so we -- terminate the loop in that case. P := Parent (N); @@ -1191,8 +1247,8 @@ package body Sem_Elab is if No (Outer_Scope) then Elab_Visited.Set_Last (0); - -- Nothing to do if current scope is Standard (this is a bit - -- odd, but it happens in the case of generic instantiations). + -- Nothing to do if current scope is Standard (this is a bit odd, but + -- it happens in the case of generic instantiations). C_Scope := Current_Scope; @@ -1205,9 +1261,8 @@ package body Sem_Elab is From_Elab_Code := not In_Subprogram_Or_Concurrent_Unit; if From_Elab_Code then - -- Complain if call that comes from source in preelaborated - -- unit and we are not inside a subprogram (i.e. we are in - -- elab code) + -- Complain if call that comes from source in preelaborated unit + -- and we are not inside a subprogram (i.e. we are in elab code). if Comes_From_Source (N) and then In_Preelaborated_Unit @@ -1375,14 +1430,19 @@ package body Sem_Elab is C_Scope := Current_Scope; - -- If not outer level call, then we follow it if it is within - -- the original scope of the outer call. + -- If not outer level call, then we follow it if it is within the + -- original scope of the outer call. if Present (Outer_Scope) and then Within (Scope (Ent), Outer_Scope) then Set_C_Scope; - Check_A_Call (N, Ent, Outer_Scope, Inter_Unit_Only => False); + Check_A_Call + (N => N, + E => Ent, + Outer_Scope => Outer_Scope, + Inter_Unit_Only => False, + In_Init_Proc => In_Init_Proc); elsif Elaboration_Checks_Suppressed (Current_Scope) then null; @@ -1407,7 +1467,7 @@ package body Sem_Elab is (N, Ent, Standard_Standard, - Inter_Unit_Only => True, + Inter_Unit_Only => True, Generate_Warnings => False); -- Otherwise nothing to do @@ -1418,9 +1478,9 @@ package body Sem_Elab is -- A call to an Init_Proc in elaboration code may bring additional -- dependencies, if some of the record components thereof have - -- initializations that are function calls that come from source. - -- We treat the current node as a call to each of these functions, - -- to check their elaboration impact. + -- initializations that are function calls that come from source. We + -- treat the current node as a call to each of these functions, to check + -- their elaboration impact. if Is_Init_Proc (Ent) and then From_Elab_Code @@ -1428,18 +1488,18 @@ package body Sem_Elab is Process_Init_Proc : declare Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent); - function Find_Init_Call (Nod : Node_Id) return Traverse_Result; + function Check_Init_Call (Nod : Node_Id) return Traverse_Result; -- Find subprogram calls within body of Init_Proc for Traverse -- instantiation below. - procedure Traverse_Body is new Traverse_Proc (Find_Init_Call); + procedure Traverse_Body is new Traverse_Proc (Check_Init_Call); -- Traversal procedure to find all calls with body of Init_Proc - -------------------- - -- Find_Init_Call -- - -------------------- + --------------------- + -- Check_Init_Call -- + --------------------- - function Find_Init_Call (Nod : Node_Id) return Traverse_Result is + function Check_Init_Call (Nod : Node_Id) return Traverse_Result is Func : Entity_Id; begin @@ -1459,7 +1519,7 @@ package body Sem_Elab is else return OK; end if; - end Find_Init_Call; + end Check_Init_Call; -- Start of processing for Process_Init_Proc @@ -1483,9 +1543,9 @@ package body Sem_Elab is Pkg_Body : Entity_Id; begin - -- For record or array component, check prefix. If it is an access - -- type, then there is nothing to do (we do not know what is being - -- assigned), but otherwise this is an assignment to the prefix. + -- For record or array component, check prefix. If it is an access type, + -- then there is nothing to do (we do not know what is being assigned), + -- but otherwise this is an assignment to the prefix. if Nkind (N) = N_Indexed_Component or else @@ -1616,12 +1676,6 @@ package body Sem_Elab is return; end if; - -- All OK if warnings suppressed on the entity - - if Warnings_Off (Ent) then - return; - end if; - -- All OK if all warnings suppressed if Warning_Mode = Suppress then @@ -1653,16 +1707,20 @@ package body Sem_Elab is -- Here is where we give the warning - Error_Msg_Sloc := Sloc (Ent); + -- All OK if warnings suppressed on the entity - Error_Msg_NE - ("?elaboration code may access& before it is initialized", - N, Ent); - Error_Msg_NE - ("\?suggest adding pragma Elaborate_Body to spec of &", - N, Scop); - Error_Msg_N - ("\?or an explicit initialization could be added #", N); + if not Has_Warnings_Off (Ent) then + Error_Msg_Sloc := Sloc (Ent); + + Error_Msg_NE + ("?elaboration code may access& before it is initialized", + N, Ent); + Error_Msg_NE + ("\?suggest adding pragma Elaborate_Body to spec of &", + N, Scop); + Error_Msg_N + ("\?or an explicit initialization could be added #", N); + end if; if not All_Errors_Mode then Set_Suppress_Elaboration_Warnings (Ent); @@ -1676,10 +1734,10 @@ package body Sem_Elab is procedure Check_Elab_Calls is begin - -- If expansion is disabled, do not generate any checks. Also - -- skip checks if any subunits are missing because in either - -- case we lack the full information that we need, and no object - -- file will be created in any case. + -- If expansion is disabled, do not generate any checks. Also skip + -- checks if any subunits are missing because in either case we lack the + -- full information that we need, and no object file will be created in + -- any case. if not Expander_Active or else Is_Generic_Unit (Cunit_Entity (Main_Unit)) @@ -1695,7 +1753,7 @@ package body Sem_Elab is Expander_Mode_Save_And_Set (True); for J in Delay_Check.First .. Delay_Check.Last loop - New_Scope (Delay_Check.Table (J).Curscop); + Push_Scope (Delay_Check.Table (J).Curscop); From_Elab_Code := Delay_Check.Table (J).From_Elab_Code; Check_Internal_Call_Continue ( @@ -1765,7 +1823,7 @@ package body Sem_Elab is -- outer level call. -- It is an outer level instantiation from elaboration code, or the - -- instantiated entity is in the same elaboratoin scope. + -- instantiated entity is in the same elaboration scope. -- And in these cases, we will check both the inter-unit case and -- the intra-unit (within a single unit) case. @@ -1786,11 +1844,11 @@ package body Sem_Elab is Set_C_Scope; Check_A_Call (N, Ent, Scope (Ent), Inter_Unit_Only => False); - -- If none of those cases holds, but Dynamic_Elaboration_Checks mode - -- is set, then we will do the check, but only in the inter-unit case - -- (this is to accommodate unguarded elaboration calls from other units - -- in which this same mode is set). We inhibit warnings in this case, - -- since this instantiation is not occurring in elaboration code. + -- If none of those cases holds, but Dynamic_Elaboration_Checks mode is + -- set, then we will do the check, but only in the inter-unit case (this + -- is to accommodate unguarded elaboration calls from other units in + -- which this same mode is set). We inhibit warnings in this case, since + -- this instantiation is not occurring in elaboration code. elsif Dynamic_Elaboration_Checks then Set_C_Scope; @@ -1846,10 +1904,10 @@ package body Sem_Elab is elsif not Full_Analysis then return; - -- Nothing to do if within a default expression, since the call - -- is not actualy being made at this time. + -- Nothing to do if analyzing in special spec-expression mode, since the + -- call is not actually being made at this time. - elsif In_Default_Expression then + elsif In_Spec_Expression then return; -- Nothing to do for call to intrinsic subprogram @@ -1862,19 +1920,23 @@ package body Sem_Elab is elsif In_Task_Activation then return; + + -- Nothing to do if call is within a generic unit + + elsif Inside_A_Generic then + return; end if; -- Delay this call if we are still delaying calls if Delaying_Elab_Checks then - Delay_Check.Increment_Last; - Delay_Check.Table (Delay_Check.Last) := + Delay_Check.Append ( (N => N, E => E, Orig_Ent => Orig_Ent, Curscop => Current_Scope, Outer_Scope => Outer_Scope, - From_Elab_Code => From_Elab_Code); + From_Elab_Code => From_Elab_Code)); return; -- Otherwise, call phase 2 continuation right now @@ -1937,7 +1999,7 @@ package body Sem_Elab is -- arguments that are assignments (OUT or IN OUT mode formals). elsif Nkind (N) = N_Procedure_Call_Statement then - Check_Elab_Call (N, Outer_Scope); + Check_Elab_Call (N, Outer_Scope, In_Init_Proc => Is_Init_Proc (E)); Actual := First_Actual (N); while Present (Actual) loop @@ -1956,16 +2018,16 @@ package body Sem_Elab is Check_Elab_Instantiation (N, Outer_Scope); return OK; - -- Skip subprogram bodies that come from source (wait for - -- call to analyze these). The reason for the come from - -- source test is to avoid catching task bodies. + -- Skip subprogram bodies that come from source (wait for call to + -- analyze these). The reason for the come from source test is to + -- avoid catching task bodies. - -- For task bodies, we should really avoid these too, waiting - -- for the task activation, but that's too much trouble to - -- catch for now, so we go in unconditionally. This is not - -- so terrible, it means the error backtrace is not quite - -- complete, and we are too eager to scan bodies of tasks - -- that are unused, but this is hardly very significant! + -- For task bodies, we should really avoid these too, waiting for the + -- task activation, but that's too much trouble to catch for now, so + -- we go in unconditionally. This is not so terrible, it means the + -- error backtrace is not quite complete, and we are too eager to + -- scan bodies of tasks that are unused, but this is hardly very + -- significant! elsif Nkind (N) = N_Subprogram_Body and then Comes_From_Source (N) @@ -1992,8 +2054,7 @@ package body Sem_Elab is Outer_Level_Sloc := Loc; end if; - Elab_Visited.Increment_Last; - Elab_Visited.Table (Elab_Visited.Last) := E; + Elab_Visited.Append (E); -- If the call is to a function that renames a literal, no check -- is needed. @@ -2017,8 +2078,8 @@ package body Sem_Elab is end if; end if; - -- If the body appears after the outer level call or - -- instantiation then we have an error case handled below. + -- If the body appears after the outer level call or instantiation then + -- we have an error case handled below. if Earlier_In_Extended_Unit (Outer_Level_Sloc, Sloc (Sbody)) and then not In_Task_Activation @@ -2031,15 +2092,13 @@ package body Sem_Elab is elsif Inst_Case then return; - -- Otherwise we have a call, so we trace through the called - -- body to see if it has any problems .. + -- Otherwise we have a call, so we trace through the called body to see + -- if it has any problems. else pragma Assert (Nkind (Sbody) = N_Subprogram_Body); - Elab_Call.Increment_Last; - Elab_Call.Table (Elab_Call.Last).Cloc := Loc; - Elab_Call.Table (Elab_Call.Last).Ent := E; + Elab_Call.Append ((Cloc => Loc, Ent => E)); if Debug_Flag_LL then Write_Str ("Elab_Call.Last = "); @@ -2051,9 +2110,9 @@ package body Sem_Elab is Write_Eol; end if; - -- Now traverse declarations and statements of subprogram body. - -- Note that we cannot simply Traverse (Sbody), since traverse - -- does not normally visit subprogram bodies. + -- Now traverse declarations and statements of subprogram body. Note + -- that we cannot simply Traverse (Sbody), since traverse does not + -- normally visit subprogram bodies. declare Decl : Node_Id; @@ -2071,11 +2130,36 @@ package body Sem_Elab is return; end if; - -- Here is the case of calling a subprogram where the body has - -- not yet been encountered, a warning message is needed. + -- Here is the case of calling a subprogram where the body has not yet + -- been encountered. A warning message is needed, except if this is the + -- case of appearing within an aspect specification that results in + -- a check call, we do not really have such a situation, so no warning + -- is needed (e.g. the case of a precondition, where the call appears + -- textually before the body, but in actual fact is moved to the + -- appropriate subprogram body and so does not need a check). - -- If we have nothing in the call stack, then this is at the - -- outer level, and the ABE is bound to occur. + declare + P : Node_Id; + begin + P := Parent (N); + loop + if Nkind (P) in N_Subexpr then + P := Parent (P); + elsif Nkind (P) = N_If_Statement + and then Nkind (Original_Node (P)) = N_Pragma + and then Present (Corresponding_Aspect (Original_Node (P))) + then + return; + else + exit; + end if; + end loop; + end; + + -- Not that special case, warning and dynamic check is required + + -- If we have nothing in the call stack, then this is at the outer + -- level, and the ABE is bound to occur. if Elab_Call.Last = 0 then if Inst_Case then @@ -2114,14 +2198,15 @@ package body Sem_Elab is begin Set_Elaboration_Entity (E, Ent); - New_Scope (Scope (E)); + Push_Scope (Scope (E)); Insert_Action (Declaration_Node (E), Make_Object_Declaration (Loce, Defining_Identifier => Ent, - Object_Definition => - New_Occurrence_Of (Standard_Boolean, Loce), - Expression => New_Occurrence_Of (Standard_False, Loce))); + Object_Definition => + New_Occurrence_Of (Standard_Short_Integer, Loce), + Expression => + Make_Integer_Literal (Loc, Uint_0))); -- Set elaboration flag at the point of the body @@ -2140,10 +2225,12 @@ package body Sem_Elab is end; end if; - -- Generate check of the elaboration Boolean + -- Generate check of the elaboration counter Insert_Elab_Check (N, - New_Occurrence_Of (Elaboration_Entity (E), Loc)); + Make_Attribute_Reference (Loc, + Attribute_Name => Name_Elaborated, + Prefix => New_Occurrence_Of (E, Loc))); end if; -- Generate the warning @@ -2260,7 +2347,7 @@ package body Sem_Elab is ("task will be activated before elaboration of its body?", Decl); Error_Msg_N - ("\Program_Error will be raised at run-time?", Decl); + ("\Program_Error will be raised at run time?", Decl); elsif Present (Corresponding_Body (Unit_Declaration_Node (Proc))) @@ -2382,15 +2469,14 @@ package body Sem_Elab is and then not Restriction_Active (No_Entry_Calls_In_Elaboration_Code) then - -- Runtime elaboration check required. generate check of the - -- elaboration Boolean for the unit containing the entity. + -- Runtime elaboration check required. Generate check of the + -- elaboration counter for the unit containing the entity. Insert_Elab_Check (N, Make_Attribute_Reference (Loc, Attribute_Name => Name_Elaborated, Prefix => - New_Occurrence_Of - (Spec_Entity (Task_Scope), Loc))); + New_Occurrence_Of (Spec_Entity (Task_Scope), Loc))); end if; else @@ -2403,7 +2489,8 @@ package body Sem_Elab is and then not Elaboration_Checks_Suppressed (Task_Scope) then Error_Msg_Node_2 := Task_Scope; - Error_Msg_NE ("activation of an instance of task type&" & + Error_Msg_NE + ("activation of an instance of task type&" & " requires pragma Elaborate_All on &?", N, Ent); end if; @@ -2445,8 +2532,8 @@ package body Sem_Elab is and then Present (Parameter_Associations (Call)) and then Is_Controlled (Etype (First_Actual (Call))); begin - -- If the unit is mentioned in a with_clause of the current - -- unit, it is visible, and we can set the elaboration flag. + -- If the unit is mentioned in a with_clause of the current unit, it is + -- visible, and we can set the elaboration flag. if Is_Immediately_Visible (Scop) or else (Is_Child_Unit (Scop) and then Is_Visible_Child_Unit (Scop)) @@ -2473,9 +2560,9 @@ package body Sem_Elab is return; end if; - -- If the unit is not in the context, there must be an intermediate - -- unit that is, on which we need to place to elaboration flag. This - -- happens with init proc calls. + -- If the unit is not in the context, there must be an intermediate unit + -- that is, on which we need to place to elaboration flag. This happens + -- with init proc calls. if Is_Init_Proc (Subp) or else Init_Call @@ -2529,30 +2616,29 @@ package body Sem_Elab is function Find_Body_In (E : Entity_Id; N : Node_Id) return Node_Id; -- Determine if the list of nodes headed by N and linked by Next - -- contains a package body for the package spec entity E, and if - -- so return the package body. If not, then returns Empty. + -- contains a package body for the package spec entity E, and if so + -- return the package body. If not, then returns Empty. function Load_Package_Body (Nam : Unit_Name_Type) return Node_Id; -- This procedure is called load the unit whose name is given by Nam. -- This unit is being loaded to see whether it contains an optional - -- generic body. The returned value is the loaded unit, which is - -- always a package body (only package bodies can contain other - -- entities in the sense in which Has_Generic_Body is interested). - -- We only attempt to load bodies if we are generating code. If we - -- are in semantics check only mode, then it would be wrong to load - -- bodies that are not required from a semantic point of view, so - -- in this case we return Empty. The result is that the caller may - -- incorrectly decide that a generic spec does not have a body when - -- in fact it does, but the only harm in this is that some warnings - -- on elaboration problems may be lost in semantic checks only mode, - -- which is not big loss. We also return Empty if we go for a body - -- and it is not there. + -- generic body. The returned value is the loaded unit, which is always + -- a package body (only package bodies can contain other entities in the + -- sense in which Has_Generic_Body is interested). We only attempt to + -- load bodies if we are generating code. If we are in semantics check + -- only mode, then it would be wrong to load bodies that are not + -- required from a semantic point of view, so in this case we return + -- Empty. The result is that the caller may incorrectly decide that a + -- generic spec does not have a body when in fact it does, but the only + -- harm in this is that some warnings on elaboration problems may be + -- lost in semantic checks only mode, which is not big loss. We also + -- return Empty if we go for a body and it is not there. function Locate_Corresponding_Body (PE : Entity_Id) return Node_Id; -- PE is the entity for a package spec. This function locates the - -- corresponding package body, returning Empty if none is found. - -- The package body returned is fully parsed but may not yet be - -- analyzed, so only syntactic fields should be referenced. + -- corresponding package body, returning Empty if none is found. The + -- package body returned is fully parsed but may not yet be analyzed, + -- so only syntactic fields should be referenced. ------------------ -- Find_Body_In -- @@ -2634,17 +2720,17 @@ package body Sem_Elab is begin if Is_Library_Level_Entity (PE) then - -- If package is a library unit that requires a body, we have - -- no choice but to go after that body because it might contain - -- an optional body for the original generic package. + -- If package is a library unit that requires a body, we have no + -- choice but to go after that body because it might contain an + -- optional body for the original generic package. if Unit_Requires_Body (PE) then - -- Load the body. Note that we are a little careful here to - -- use Spec to get the unit number, rather than PE or Decl, - -- since in the case where the package is itself a library - -- level instantiation, Spec will properly reference the - -- generic template, which is what we really want. + -- Load the body. Note that we are a little careful here to use + -- Spec to get the unit number, rather than PE or Decl, since + -- in the case where the package is itself a library level + -- instantiation, Spec will properly reference the generic + -- template, which is what we really want. return Load_Package_Body @@ -2823,10 +2909,12 @@ package body Sem_Elab is Typ : constant Entity_Id := Etype (N); Chk : constant Boolean := Do_Range_Check (N); - R : constant Node_Id := - Make_Raise_Program_Error (Loc, + R : constant Node_Id := + Make_Raise_Program_Error (Loc, Reason => PE_Access_Before_Elaboration); + Reloc_N : Node_Id; + begin Set_Etype (R, Typ); @@ -2834,9 +2922,11 @@ package body Sem_Elab is Rewrite (N, R); else + Reloc_N := Relocate_Node (N); + Save_Interps (N, Reloc_N); Rewrite (N, Make_Conditional_Expression (Loc, - Expressions => New_List (C, Relocate_Node (N), R))); + Expressions => New_List (C, Reloc_N, R))); end if; Analyze_And_Resolve (N, Typ); @@ -2868,6 +2958,53 @@ package body Sem_Elab is end if; end Insert_Elab_Check; + ------------------------------- + -- Is_Finalization_Procedure -- + ------------------------------- + + function Is_Finalization_Procedure (Id : Entity_Id) return Boolean is + begin + -- Check whether Id is a procedure with at least one parameter + + if Ekind (Id) = E_Procedure + and then Present (First_Formal (Id)) + then + declare + Typ : constant Entity_Id := Etype (First_Formal (Id)); + Deep_Fin : Entity_Id := Empty; + Fin : Entity_Id := Empty; + + begin + -- If the type of the first formal does not require finalization + -- actions, then this is definitely not [Deep_]Finalize. + + if not Needs_Finalization (Typ) then + return False; + end if; + + -- At this point we have the following scenario: + + -- procedure Name (Param1 : [in] [out] Ctrl[; Param2 : ...]); + + -- Recover the two possible versions of [Deep_]Finalize using the + -- type of the first parameter and compare with the input. + + Deep_Fin := TSS (Typ, TSS_Deep_Finalize); + + if Is_Controlled (Typ) then + Fin := Find_Prim_Op (Typ, Name_Finalize); + end if; + + return + (Present (Deep_Fin) and then Id = Deep_Fin) + or else + (Present (Fin) and then Id = Fin); + end; + end if; + + return False; + end Is_Finalization_Procedure; + ------------------ -- Output_Calls -- ------------------ @@ -2981,10 +3118,7 @@ package body Sem_Elab is -- Check for case of body entity -- Why is the check for E_Void needed??? - if Ekind (E) = E_Void - or else Ekind (E) = E_Subprogram_Body - or else Ekind (E) = E_Package_Body - then + if Ekind_In (E, E_Void, E_Subprogram_Body, E_Package_Body) then Decl := E; loop @@ -3009,15 +3143,62 @@ package body Sem_Elab is declare Ent : constant Entity_Id := Defining_Unit_Name (Specification (N)); begin - Set_Is_Imported (Ent); - Set_Convention (Ent, Convention_Stubbed); + + -- Internal subprograms will already have a generated body, so + -- there is no need to provide a stub for them. + + if No (Corresponding_Body (N)) then + declare + Loc : constant Source_Ptr := Sloc (N); + B : Node_Id; + Formals : constant List_Id := Copy_Parameter_List (Ent); + Nam : constant Entity_Id := + Make_Defining_Identifier (Loc, Chars (Ent)); + Spec : Node_Id; + Stats : constant List_Id := + New_List + (Make_Raise_Program_Error (Loc, + Reason => PE_Access_Before_Elaboration)); + + begin + if Ekind (Ent) = E_Function then + Spec := + Make_Function_Specification (Loc, + Defining_Unit_Name => Nam, + Parameter_Specifications => Formals, + Result_Definition => + New_Copy_Tree + (Result_Definition (Specification (N)))); + + -- We cannot reliably make a return statement for this + -- body, but none is needed because the call raises + -- program error. + + Set_Return_Present (Ent); + + else + Spec := + Make_Procedure_Specification (Loc, + Defining_Unit_Name => Nam, + Parameter_Specifications => Formals); + end if; + + B := Make_Subprogram_Body (Loc, + Specification => Spec, + Declarations => New_List, + Handled_Statement_Sequence => + Make_Handled_Sequence_Of_Statements (Loc, Stats)); + Insert_After (N, B); + Analyze (B); + end; + end if; end; elsif Nkind (N) = N_Package_Declaration then declare Spec : constant Node_Id := Specification (N); begin - New_Scope (Defining_Unit_Name (Spec)); + Push_Scope (Defining_Unit_Name (Spec)); Supply_Bodies (Visible_Declarations (Spec)); Supply_Bodies (Private_Declarations (Spec)); Pop_Scope; @@ -3043,22 +3224,17 @@ package body Sem_Elab is function Within (E1, E2 : Entity_Id) return Boolean is Scop : Entity_Id; - begin Scop := E1; loop if Scop = E2 then return True; - elsif Scop = Standard_Standard then return False; - else Scop := Scope (Scop); end if; end loop; - - raise Program_Error; end Within; -------------------------- @@ -3075,7 +3251,7 @@ package body Sem_Elab is Item := First (Context_Items (Cunit (Current_Sem_Unit))); while Present (Item) loop if Nkind (Item) = N_Pragma - and then Get_Pragma_Id (Chars (Item)) = Pragma_Elaborate_All + and then Pragma_Name (Item) = Name_Elaborate_All then -- Return if some previous error on the pragma itself