sem_elab.adb (Check_A_Call): Specialize elaboration warnings on elaboration model

2007-04-20  Robert Dewar  <dewar@adacore.com>

	* sem_elab.adb (Check_A_Call): Specialize elaboration warnings on
	elaboration model
	(Check_A_Call): Add check for entry call which was causing blowup

From-SVN: r125454

diff --git a/gcc/ada/sem_elab.adb b/gcc/ada/sem_elab.adb
index e3f72e4f112a1b90579e72a03a1d25f32710bc73..bae6a9fd96e681e1c0e44089ebfaa0cc93ff69b5 100644 (file)
--- a/gcc/ada/sem_elab.adb
+++ b/gcc/ada/sem_elab.adb
@@ -6,7 +6,7 @@
 --                                                                          --
 --                                 B o d y                                  --
 --                                                                          --
---          Copyright (C) 1997-2006, Free Software Foundation, Inc.         --
+--          Copyright (C) 1997-2007, 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- --
@@ -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?",
+                     "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?",
+                        "implicit call to & during elaboration?",
+                        Ent);
+
+                  else
+                     Elab_Warning
+                       ("call to & may raise Program_Error?",
+                        "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&?",
+                     "\implicit pragma Elaborate for& generated?",
+                     W_Scope);
+               else
+                  Elab_Warning
+                    ("\missing pragma Elaborate_All for&?",
+                     "\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);
@@ -1695,7 +1734,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 (
@@ -2114,7 +2153,7 @@ 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,
@@ -3017,7 +3056,7 @@ package body Sem_Elab is
          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;