From a5abb241f3c53daf6ebbb82992b5227fcdb750c5 Mon Sep 17 00:00:00 2001 From: Robert Dewar Date: Tue, 31 Oct 2006 19:09:19 +0100 Subject: [PATCH] sem_elab.ads, [...] (Check_Elab_Assign): New procedure Add new calls to this procedure during traversal 2006-10-31 Robert Dewar Ed Schonberg * sem_elab.ads, sem_elab.adb (Check_Elab_Assign): New procedure Add new calls to this procedure during traversal (Activate_Elaborate_All_Desirable): Do not set elaboration flag on another unit if expansion is disabled. From-SVN: r118309 --- gcc/ada/sem_elab.adb | 318 +++++++++++++++++++++++++++++++++++++------ gcc/ada/sem_elab.ads | 18 ++- 2 files changed, 289 insertions(+), 47 deletions(-) diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb index ec0a56db126..2e4b5c8fc79 100644 --- a/gcc/ada/sem_elab.adb +++ b/gcc/ada/sem_elab.adb @@ -403,6 +403,13 @@ package body Sem_Elab is -- Start of processing for Activate_Elaborate_All_Desirable begin + -- Do not set binder indication if expansion is disabled, as when + -- compiling a generic unit. + + if not Expander_Active then + return; + end if; + Itm := First (CI); while Present (Itm) loop if Nkind (Itm) = N_With_Clause then @@ -1150,15 +1157,14 @@ package body Sem_Elab is Write_Eol; end if; - -- Climb up the tree to make sure we are not inside a - -- default expression of a parameter specification or - -- a record component, since in both these cases, we - -- will be doing the actual call later, not now, and it - -- 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 + -- Climb up the tree to make sure we are not inside default expression + -- of a parameter specification or a record component, since in both + -- these cases, we will be doing the actual call later, not now, and it + -- 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 -- terminate the loop in that case. P := Parent (N); @@ -1327,8 +1333,8 @@ package body Sem_Elab is return; -- Static model, call is not in elaboration code, we - -- never need to worry, because in the static model - -- the top level caller always takes care of things. + -- never need to worry, because in the static model the + -- top level caller always takes care of things. else return; @@ -1422,11 +1428,18 @@ package body Sem_Elab is Process_Init_Proc : declare Unit_Decl : constant Node_Id := Unit_Declaration_Node (Ent); - function Process (Nod : Node_Id) return Traverse_Result; - -- Find subprogram calls within body of init_proc for - -- Traverse instantiation below. + function Find_Init_Call (Nod : Node_Id) return Traverse_Result; + -- Find subprogram calls within body of Init_Proc for Traverse + -- instantiation below. - function Process (Nod : Node_Id) return Traverse_Result is + procedure Traverse_Body is new Traverse_Proc (Find_Init_Call); + -- Traversal procedure to find all calls with body of Init_Proc + + -------------------- + -- Find_Init_Call -- + -------------------- + + function Find_Init_Call (Nod : Node_Id) return Traverse_Result is Func : Entity_Id; begin @@ -1446,9 +1459,7 @@ package body Sem_Elab is else return OK; end if; - end Process; - - procedure Traverse_Body is new Traverse_Proc (Process); + end Find_Init_Call; -- Start of processing for Process_Init_Proc @@ -1460,6 +1471,205 @@ package body Sem_Elab is end if; end Check_Elab_Call; + ----------------------- + -- Check_Elab_Assign -- + ----------------------- + + procedure Check_Elab_Assign (N : Node_Id) is + Ent : Entity_Id; + Scop : Entity_Id; + + Pkg_Spec : Entity_Id; + 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. + + if Nkind (N) = N_Indexed_Component + or else + Nkind (N) = N_Selected_Component + or else + Nkind (N) = N_Slice + then + if not Is_Access_Type (Etype (Prefix (N))) then + Check_Elab_Assign (Prefix (N)); + end if; + + return; + end if; + + -- For type conversion, check expression + + if Nkind (N) = N_Type_Conversion then + Check_Elab_Assign (Expression (N)); + return; + end if; + + -- Nothing to do if this is not an entity reference otherwise get entity + + if Is_Entity_Name (N) then + Ent := Entity (N); + else + return; + end if; + + -- What we are looking for is a reference in the body of a package that + -- modifies a variable declared in the visible part of the package spec. + + if Present (Ent) + and then Comes_From_Source (N) + and then not Suppress_Elaboration_Warnings (Ent) + and then Ekind (Ent) = E_Variable + and then not In_Private_Part (Ent) + and then Is_Library_Level_Entity (Ent) + then + Scop := Current_Scope; + loop + if No (Scop) or else Scop = Standard_Standard then + return; + elsif Ekind (Scop) = E_Package + and then Is_Compilation_Unit (Scop) + then + exit; + else + Scop := Scope (Scop); + end if; + end loop; + + -- Here Scop points to the containing library package + + Pkg_Spec := Scop; + Pkg_Body := Body_Entity (Pkg_Spec); + + -- All OK if the package has an Elaborate_Body pragma + + if Has_Pragma_Elaborate_Body (Scop) then + return; + end if; + + -- OK if entity being modified is not in containing package spec + + if not In_Same_Source_Unit (Scop, Ent) then + return; + end if; + + -- All OK if entity appears in generic package or generic instance. + -- We just get too messed up trying to give proper warnings in the + -- presence of generics. Better no message than a junk one. + + Scop := Scope (Ent); + while Present (Scop) and then Scop /= Pkg_Spec loop + if Ekind (Scop) = E_Generic_Package then + return; + elsif Ekind (Scop) = E_Package + and then Is_Generic_Instance (Scop) + then + return; + end if; + + Scop := Scope (Scop); + end loop; + + -- All OK if in task, don't issue warnings there + + if In_Task_Activation then + return; + end if; + + -- OK if no package body + + if No (Pkg_Body) then + return; + end if; + + -- OK if reference is not in package body + + if not In_Same_Source_Unit (Pkg_Body, N) then + return; + end if; + + -- OK if package body has no handled statement sequence + + declare + HSS : constant Node_Id := + Handled_Statement_Sequence (Declaration_Node (Pkg_Body)); + begin + if No (HSS) or else not Comes_From_Source (HSS) then + return; + end if; + end; + + -- We definitely have a case of a modification of an entity in + -- the package spec from the elaboration code of the package body. + -- We may not give the warning (because there are some additional + -- checks to avoid too many false positives), but it would be a good + -- idea for the binder to try to keep the body elaboration close to + -- the spec elaboration. + + Set_Elaborate_Body_Desirable (Pkg_Spec); + + -- All OK in gnat mode (we know what we are doing) + + if GNAT_Mode then + 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 + return; + end if; + + -- All OK if elaboration checks suppressed for entity + + if Checks_May_Be_Suppressed (Ent) + and then Is_Check_Suppressed (Ent, Elaboration_Check) + then + return; + end if; + + -- OK if the entity is initialized. Note that the No_Initialization + -- flag usually means that the initialization has been rewritten into + -- assignments, but that still counts for us. + + declare + Decl : constant Node_Id := Declaration_Node (Ent); + begin + if Nkind (Decl) = N_Object_Declaration + and then (Present (Expression (Decl)) + or else No_Initialization (Decl)) + then + return; + end if; + end; + + -- Here is where we give the warning + + 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); + + if not All_Errors_Mode then + Set_Suppress_Elaboration_Warnings (Ent); + end if; + end if; + end Check_Elab_Assign; + ---------------------- -- Check_Elab_Calls -- ---------------------- @@ -1690,16 +1900,22 @@ package body Sem_Elab is Sbody : Node_Id; Ebody : Entity_Id; - function Process (N : Node_Id) return Traverse_Result; - -- Function applied to each node as we traverse the body. - -- Checks for call that needs checking, and if so checks - -- it. Always returns OK, so entire tree is traversed. + function Find_Elab_Reference (N : Node_Id) return Traverse_Result; + -- Function applied to each node as we traverse the body. Checks for + -- call or entity reference that needs checking, and if so checks it. + -- Always returns OK, so entire tree is traversed, except that as + -- described below subprogram bodies are skipped for now. + + procedure Traverse is new Atree.Traverse_Proc (Find_Elab_Reference); + -- Traverse procedure using above Find_Elab_Reference function + + ------------------------- + -- Find_Elab_Reference -- + ------------------------- - ------------- - -- Process -- - ------------- + function Find_Elab_Reference (N : Node_Id) return Traverse_Result is + Actual : Node_Id; - function Process (N : Node_Id) return Traverse_Result is begin -- If user has specified that there are no entry calls in elaboration -- code, do not trace past an accept statement, because the rendez- @@ -1711,12 +1927,27 @@ package body Sem_Elab is then return Abandon; - -- If we have a subprogram call, check it + -- If we have a function call, check it - elsif Nkind (N) = N_Function_Call - or else Nkind (N) = N_Procedure_Call_Statement - then + elsif Nkind (N) = N_Function_Call then + Check_Elab_Call (N, Outer_Scope); + return OK; + + -- If we have a procedure call, check the call, and also check + -- arguments that are assignments (OUT or IN OUT mode formals). + + elsif Nkind (N) = N_Procedure_Call_Statement then Check_Elab_Call (N, Outer_Scope); + + Actual := First_Actual (N); + while Present (Actual) loop + if Known_To_Be_Assigned (Actual) then + Check_Elab_Assign (Actual); + end if; + + Next_Actual (Actual); + end loop; + return OK; -- If we have a generic instantiation, check it @@ -1741,13 +1972,16 @@ package body Sem_Elab is then return Skip; + elsif Nkind (N) = N_Assignment_Statement + and then Comes_From_Source (N) + then + Check_Elab_Assign (Name (N)); + return OK; + else return OK; end if; - end Process; - - procedure Traverse is new Atree.Traverse_Proc; - -- Traverse procedure using above Process function + end Find_Elab_Reference; -- Start of processing for Check_Internal_Call_Continue @@ -1893,13 +2127,14 @@ package body Sem_Elab is Set_Elaboration_Flag (Sbody, E); - -- Kill current value indication. This is necessary - -- because the tests of this flag are inserted out of - -- sequence and must not pick up bogus indications of - -- the wrong constant value. Also, this is never a true - -- constant, since one way or another, it gets reset. + -- Kill current value indication. This is necessary because + -- the tests of this flag are inserted out of sequence and + -- must not pick up bogus indications of the wrong constant + -- value. Also, this is never a true constant, since one way + -- or another, it gets reset. Set_Current_Value (Ent, Empty); + Set_Last_Assignment (Ent, Empty); Set_Is_True_Constant (Ent, False); Pop_Scope; end; @@ -2118,6 +2353,7 @@ package body Sem_Elab is -- We only perform detailed checks in all tasks are library level -- entities. If the master is a subprogram or task, activation will -- depend on the activation of the master itself. + -- Should dynamic checks be added in the more general case??? if Ekind (Enclosing) /= E_Package then @@ -2252,8 +2488,8 @@ package body Sem_Elab is -- object is the first actual in the call. declare - Typ : constant Entity_Id := - Etype (First (Parameter_Associations (Call))); + Typ : constant Entity_Id := + Etype (First (Parameter_Associations (Call))); begin Elab_Unit := Scope (Typ); while (Present (Elab_Unit)) diff --git a/gcc/ada/sem_elab.ads b/gcc/ada/sem_elab.ads index e42a4ab20f4..db7db675880 100644 --- a/gcc/ada/sem_elab.ads +++ b/gcc/ada/sem_elab.ads @@ -6,7 +6,7 @@ -- -- -- S p e c -- -- -- --- Copyright (C) 1997-2005, Free Software Foundation, Inc. -- +-- Copyright (C) 1997-2006, 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- -- @@ -120,11 +120,11 @@ package Sem_Elab is -- corresponding bodies. procedure Check_Elab_Call (N : Node_Id; Outer_Scope : Entity_Id := Empty); - -- Check a call for possible elaboration problems. N is either an - -- N_Function_Call or N_Procedure_Call_Statement node, and Outer - -- indicates whether this is an outer level call from Sem_Res - -- (Outer_Scope set to Empty), or an internal recursive call - -- (Outer_Scope set to entity of outermost call, see body). + -- Check a call for possible elaboration problems. The node N is either + -- an N_Function_Call or N_Procedure_Call_Statement node. The Outer_Scope + -- argument indicates whether this is an outer level call from Sem_Res + -- (Outer_Scope set to Empty), or an internal recursive call (Outer_Scope + -- set to entity of outermost call, see body). procedure Check_Elab_Calls; -- Not all the processing for Check_Elab_Call can be done at the time @@ -133,6 +133,12 @@ package Sem_Elab is -- instantiated. The Check_Elab_Calls procedure cleans up these waiting -- checks. It is called once after the completion of instantiation. + procedure Check_Elab_Assign (N : Node_Id); + -- N is either the left side of an assignment, or a procedure argument for + -- a mode OUT or IN OUT formal. This procedure checks for a possible case + -- of access to an entity from elaboration code before the entity has been + -- initialized, and issues appropriate warnings. + procedure Check_Elab_Instantiation (N : Node_Id; Outer_Scope : Entity_Id := Empty); -- 2.30.2