sem_elab.ads, [...] (Check_Elab_Assign): New procedure Add new calls to this…

sem_elab.ads, [...] (Check_Elab_Assign): New procedure Add new calls to this procedure during traversal

2006-10-31  Robert Dewar  <dewar@adacore.com>
	    Ed Schonberg  <schonberg@adacore.com>

	* 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

@@ -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))

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);